diff --git a/DESCRIPTION b/DESCRIPTION index 95c9a37..117a759 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semptools Title: Customizing Structural Equation Modelling Plots -Version: 0.3.1.11 +Version: 0.3.1.12 Authors@R: c( person(given = "Shu Fai", family = "Cheung", diff --git a/NEWS.md b/NEWS.md index 3b7f75d..fc98f63 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,4 +1,4 @@ -# semptools 0.3.1.11 +# semptools 0.3.1.12 ## New Features diff --git a/R/auto_layout_helpers.R b/R/auto_layout_helpers.R index 58ce362..a53770b 100644 --- a/R/auto_layout_helpers.R +++ b/R/auto_layout_helpers.R @@ -195,8 +195,19 @@ fix_mxy <- function( lines_i <- all_lines( m = m_new, from = x_i, - to = y_i + to = y_i, + beta = beta ) + # lines_i_to <- all_lines( + # m = m_new, + # from = x_i, + # to = m_i + # ) + # lines_i_from <- all_lines( + # m = m_new, + # from = m_i, + # to = y_i + # ) k0 <- length(m_i) # m_i_lower and m_i_upper used # when v_pos = "middle" @@ -265,7 +276,25 @@ fix_mxy <- function( m = m_new, lines_i = lines_i ) - ok <- all(unlist(chk) != 0) + lines_i_to <- all_lines( + m = m_new, + from = x_i, + to = m_ij, + beta = beta + ) + chk_to <- lapply( + x_i, + check_pass_thru, + m = m_new, + lines_i = lines_i_to) + # chk_from <- lapply( + # y_i, + # check_pass_thru, + # m = m_new, + # lines_i = lines_i_from) + tmp <- unlist(c(chk, chk_to)) + tmp <- tmp[!is.na(tmp)] + ok <- all(tmp != 0) } } } else { @@ -283,7 +312,25 @@ fix_mxy <- function( m = m_new, lines_i = lines_i ) - ok <- all(unlist(chk) != 0) + lines_i_to <- all_lines( + m = m_new, + from = x_i, + to = m_i, + beta = beta + ) + chk_to <- lapply( + x_i, + check_pass_thru, + m = m_new, + lines_i = lines_i_to) + # chk_from <- lapply( + # y_i, + # check_pass_thru, + # m = m_new, + # lines_i = lines_i_from) + tmp <- unlist(c(chk, chk_to)) + tmp <- tmp[!is.na(tmp)] + ok <- all(tmp != 0) } } } @@ -294,23 +341,39 @@ fix_mxy <- function( # - m: Layout x-y matrix # - from: Lines from # - to: Lines to +# - The beta matrix # Output: # - A list of equations all_lines <- function(m, from, - to) { + to, + beta) { out <- vector("list", length(from) * length(to)) - i <- 1 + i <- 0 + if (missing(beta)) { + beta <- matrix(1, + ncol = length(from), + nrow = length(to)) + colnames(beta) <- from + rownames(beta) <- to + } for (p1 in from) { for (p2 in to) { - a <- m[p1, "y"] - m[p2, "y"] - b <- m[p2, "x"] - m[p1, "x"] - c <- m[p1, "x"] * m[p2, "y"] - - m[p2, "x"] * m[p1, "y"] - out[[i]] <- c(a = a, b = b, c = c) - i <- i + 1 + if ((p1 != p2) && + (beta[p2, p1] > 0)) { + i <- i + 1 + a <- m[p1, "y"] - m[p2, "y"] + b <- m[p2, "x"] - m[p1, "x"] + c <- m[p1, "x"] * m[p2, "y"] - + m[p2, "x"] * m[p1, "y"] + tmp <- c(a = a, b = b, c = c) + attr(tmp, "from") <- p1 + attr(tmp, "to") <- p2 + out[[i]] <- tmp + } } } + out <- out[seq_len(i)] out } @@ -330,10 +393,34 @@ check_pass_thru <- function( chk <- sapply( lines_i, function(xx) { - xx["a"] * m[mm, "x"] + - xx["b"] * m[mm, "y"] + - xx["c"] + if (all(xx == 0)) { + return(-1) + } else { + m_x <- m[mm, "x"] + m_y <- m[mm, "y"] + tmp <- xx["a"] * m_x + + xx["b"] * m_y + + xx["c"] + tmp <- round(tmp, 4) + if (tmp == 0) { + to <- attr(xx, "to") + from <- attr(xx, "from") + x_range <- range(m[c(from, to), "x"]) + y_range <- range(m[c(from, to), "y"]) + if (m_x <= max(x_range) && m_x >= min(x_range) && + m_y <= max(y_range) && m_y >= min(y_range)) { + return(0) + } else { + return(1) + } + } + tmp + } }) + in_to <- (mm == sapply(lines_i, attr, which = "to")) + in_from <- (mm == sapply(lines_i, attr, which = "from")) + chk[in_to] <- -1 + chk[in_from] <- -1 out[[mm]] <- chk } out @@ -506,4 +593,30 @@ has_intercept <- function(object) { # - Logical is_multigroup_qgraph <- function(object) { all(sapply(object, \(x) inherits(x, "qgraph"))) -} \ No newline at end of file +} + +# Input: +# - A qgraph object +# Output: +# - Whether any path passes through any node +check_graph_pass_thru <- function(object) { + + m <- qgraph_to_layoutxy(object) + beta <- qgraph_to_beta(object) + vnames <- colnames(beta) + + lines_i <- all_lines( + m, + from = vnames, + to = vnames, + beta = beta + ) + chk <- lapply( + vnames, + check_pass_thru, + m = m, + lines_i = lines_i) + chk <- unlist(chk) + chk <- chk[!is.na(chk)] + all(chk != 0) +} diff --git a/R/safe_edge_label_positions_helpers.R b/R/safe_edge_label_positions_helpers.R index 22fc29e..435a62a 100644 --- a/R/safe_edge_label_positions_helpers.R +++ b/R/safe_edge_label_positions_helpers.R @@ -6,17 +6,17 @@ all_paths <- function( beta, m) { - all_paths <- mapply( + out <- mapply( \(x, y) {list(from = x, to = y)}, x = colnames(beta)[col(beta)[beta > 0]], y = rownames(beta)[row(beta)[beta > 0]], SIMPLIFY = FALSE, USE.NAMES = FALSE ) - all_paths <- lapply(all_paths, + out <- lapply(out, to_bezier, m = m) - all_paths + out } @@ -102,57 +102,6 @@ to_bezier <- function( coef_y = c(a = ay, b = by)) } - -# Input: -# - m_i: The names of the mediators -# - m: The layout matrix in x-y form -# - lines_i: The a, b, c for the lines that may pass through m_i -# Output: -#- A list of vectors. If 0, a mediator is on a line. -check_pass_thru <- function( - m_i, - m, - lines_i) { - out <- vector("list", length(m_i)) - names(out) <- m_i - for (mm in m_i) { - chk <- sapply( - lines_i, - function(xx) { - xx["a"] * m[mm, "x"] + - xx["b"] * m[mm, "y"] + - xx["c"] - }) - out[[mm]] <- chk - } - out -} - - -# Input: -# - m: Layout matrix -# - from: Lines from -# - to: Lines to -# Output: -# - A list of equations -all_lines <- function(m, - from, - to) { - out <- vector("list", length(from) * length(to)) - i <- 1 - for (p1 in from) { - for (p2 in to) { - a <- m[p1, "y"] - m[p2, "y"] - b <- m[p2, "x"] - m[p1, "x"] - c <- m[p1, "x"] * m[p2, "y"] - - m[p2, "x"] * m[p1, "y"] - out[[i]] <- c(a = a, b = b, c = c) - i <- i + 1 - } - } - out -} - # Input: # - A layout matrix # Output: diff --git a/README.md b/README.md index 483adb3..7ee13a5 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![R-CMD-check](https://github.com/sfcheung/semptools/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/sfcheung/semptools/actions/workflows/R-CMD-check.yaml) -(Version 0.3.1.11, updated on 2025-07-06, [release history](https://sfcheung.github.io/semptools/news/index.html)) +(Version 0.3.1.12, updated on 2025-07-09, [release history](https://sfcheung.github.io/semptools/news/index.html)) # semptools diff --git a/tests/testthat/test-auto_layout_mediation.R b/tests/testthat/test-auto_layout_mediation.R index a84c9b2..6342185 100644 --- a/tests/testthat/test-auto_layout_mediation.R +++ b/tests/testthat/test-auto_layout_mediation.R @@ -29,12 +29,23 @@ m <- auto_layout_mediation( exclude = c("c1", "c2", "c3") ) -m_chk <- structure(c("x2", NA, "x1", NA, "x3", NA, "x4", NA, NA, "x5", -NA, NA, NA, "y", NA), dim = c(3L, 5L)) + +m_chk <-structure(c(NA, "x2", NA, "x1", NA, NA, "x3", NA, "x4", NA, NA, +NA, NA, "x5", NA, NA, NA, NA, "y", NA), dim = 4:5) expect_equal(m, m_chk) +pm <- semPlotModel(fit) |> drop_nodes(c("c1", "c2", "c3")) +p0 <- semPaths( + pm, + whatLabels = "est", + layout = m, + DoNotPlot = TRUE + ) +# plot(p0) +expect_true(check_graph_pass_thru(p0)) + mxy <- auto_layout_mediation( fit, exclude = c("c1", "c2", "c3"), @@ -67,21 +78,15 @@ m <- auto_layout_mediation( exclude = c("y") ) -m_chk <- structure(c("c1", NA, "c3", NA, "x2", NA, "x1", NA, NA, NA, "x3", -NA, NA, NA, NA, NA, NA, "x4", NA, NA, NA, NA, NA, NA, "x5", NA, -NA, NA), dim = c(7L, 4L)) - -expect_equal(m, - m_chk) - -# pm <- semPlotModel(fit) |> drop_nodes(c("y", "c2")) -# p0 <- semPaths( -# pm, -# whatLabels = "est", -# layout = m, -# exoCov = FALSE, -# DoNotPlot = TRUE -# ) +pm <- semPlotModel(fit) |> drop_nodes(c("y", "c2")) +p0 <- semPaths( + pm, + whatLabels = "est", + layout = m, + exoCov = FALSE, + DoNotPlot = TRUE + ) +expect_true(check_graph_pass_thru(p0)) # plot(p0) m <- auto_layout_mediation( @@ -89,22 +94,15 @@ m <- auto_layout_mediation( v_pos = "lower" ) -m_chk <- structure(c("c2", NA, "c1", NA, "c3", NA, "x2", NA, "x1", NA, -NA, "x3", NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, NA, "x4", NA, -NA, NA, NA, NA, NA, "x5", NA, NA, NA, NA, NA, "y", NA, NA, NA, -NA, NA, NA, NA, NA), dim = c(9L, 5L)) - -expect_equal(m, - m_chk) - -# pm <- semPlotModel(fit) -# p0 <- semPaths( -# pm, -# whatLabels = "est", -# layout = m, -# exoCov = FALSE, -# DoNotPlot = TRUE -# ) +pm <- semPlotModel(fit) +p0 <- semPaths( + pm, + whatLabels = "est", + layout = m, + exoCov = FALSE, + DoNotPlot = TRUE + ) +expect_true(check_graph_pass_thru(p0)) # plot(p0) m <- auto_layout_mediation( @@ -112,22 +110,15 @@ m <- auto_layout_mediation( v_pos = "upper" ) -m_chk <- structure(c("c2", NA, "c1", NA, "c3", NA, "x2", NA, "x1", NA, -NA, NA, NA, NA, NA, "x3", NA, NA, NA, NA, NA, "x4", NA, NA, NA, -NA, NA, NA, NA, NA, NA, NA, "x5", NA, NA, NA, NA, NA, NA, NA, -NA, NA, NA, NA, "y"), dim = c(9L, 5L)) - -expect_equal(m, - m_chk) - -# pm <- semPlotModel(fit) -# p0 <- semPaths( -# pm, -# whatLabels = "est", -# layout = m, -# exoCov = FALSE, -# DoNotPlot = TRUE -# ) +pm <- semPlotModel(fit) +p0 <- semPaths( + pm, + whatLabels = "est", + layout = m, + exoCov = FALSE, + DoNotPlot = TRUE + ) +expect_true(check_graph_pass_thru(p0)) # plot(p0) expect_error(auto_layout_mediation( diff --git a/tests/testthat/test-auto_layout_mediation_complicated.R b/tests/testthat/test-auto_layout_mediation_complicated.R new file mode 100644 index 0000000..b1ac8c6 --- /dev/null +++ b/tests/testthat/test-auto_layout_mediation_complicated.R @@ -0,0 +1,48 @@ +library(lavaan) +library(semPlot) + +test_that("auto_layout_mediation", { + +mod_pa <- +" +x1 ~ x2 +x1 ~ x3 +x1 ~ x4 +x1 ~ x5 +x1 ~ x6 +x3 ~ x2 +x4 ~ x2 +x5 ~ x2 +x6 ~ x2 +x4 ~ x3 +x5 ~ x3 +x6 ~ x3 +x5 ~ x4 +x6 ~ x4 +" + +fit <- lavaan::sem( + mod_pa, + do.fit = FALSE + ) +dat <- simulateData( + parameterTable(fit), + sample.nobs = 500, + seed = 1234 + ) +fit <- lavaan::sem( + mod_pa, + dat + ) + +p0 <- semPaths( + fit, + whatLabels = "est", + DoNotPlot = TRUE + ) +p1 <- auto_layout_mediation(p0) +# plot(p1) + +expect_true(check_graph_pass_thru(p1)) + +}) diff --git a/tests/testthat/test-auto_rotate_resid.R b/tests/testthat/test-auto_rotate_resid.R index dc71f94..c455625 100644 --- a/tests/testthat/test-auto_rotate_resid.R +++ b/tests/testthat/test-auto_rotate_resid.R @@ -43,11 +43,12 @@ p1 <- safe_resid_position(p0) plot(p1) -out_chk <- c(-1.5707963267949, 0, 0.553574358897045, -4.15881462148764, --2.67794504458899, -1.01722196789785) +out_chk <- c(-3.6052402625906, 0.169646307227022, -2.21429743558818, -4.24874137138388, +-2.58801829469275, -1.40115001956787) expect_equal(p1$graphAttributes$Node$loopRotation, - out_chk) + out_chk, + tolerance = 1e-4) pos_new <- safe_resid_position(p0, update_plot = FALSE) @@ -66,9 +67,11 @@ p3 <- p0 |> rotate_resid(pos_new2) # Can be different from using qgraph object # because the aspect ratio may not be 1-to-1 in qgraph -pos_new2_chk <- c(x2 = -67.5, x3 = -202.5, x1 = -135, y = -247.5, x5 = 22.5) +pos_new2_chk <- c(x2 = -80.782525588539, x3 = -202.5, x4 = 9.21747441146101, +x1 = -140.65496623701, y = -247.5, x5 = -135) expect_equal(pos_new2, - pos_new2_chk) + pos_new2_chk, + tolerance = 1e-4) })