Merge pull request #95 from sfcheung/devel

0.1.9.15

.github/workflows/pkgdown.yaml

@@ -28,9 +28,27 @@ jobs:
 
       - uses: r-lib/actions/setup-r-dependencies@v2
         with:
-          extra-packages: any::pkgdown, any::XML, local::.
+          extra-packages: any::pkgdown, any::XML, any::DiagrammeR, local::.
           needs: website
 
+      - name: Update mermaid
+        run: |
+          # Adapted from https://github.com/rich-iannone/DiagrammeR/issues/457#issuecomment-1109995343
+          mm_loc <- list.files(
+            find.package("DiagrammeR"),
+            recursive = TRUE,
+            pattern = "mermaid.*js",
+            full.names = TRUE
+          )
+          mm_dir <- dirname(mm_loc)
+          mm_loc_old <- file.path(mm_dir, "mm.old")
+          mm_loc_new <- file.path(mm_dir, "mm.new")
+          file.copy(mm_loc, mm_loc_old, overwrite = TRUE)
+          mm_url <- "https://cdnjs.cloudflare.com/ajax/libs/mermaid/9.0.1/mermaid.min.js"
+          utils::download.file(mm_url, mm_loc_new)
+          file.copy(mm_loc_new, mm_loc, overwrite = TRUE)
+        shell: Rscript {0}
+
       - name: Build site
         run: pkgdown::build_site_github_pages(new_process = FALSE, install = FALSE)
         shell: Rscript {0}

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: manymome
 Title: Mediation, Moderation and Moderated-Mediation After Model Fitting
-Version: 0.1.9.7
+Version: 0.1.9.15
 Authors@R:
     c(person(given = "Shu Fai",
            family = "Cheung",
@@ -33,6 +33,9 @@ Suggests:
     rmarkdown,
     semPlot,
     semptools,
+    semTools,
+    Amelia,
+    mice,
     testthat (>= 3.0.0)
 Config/testthat/edition: 3
 Config/testthat/parallel: true
@@ -45,7 +48,8 @@ Imports:
     stats,
     ggplot2,
     igraph,
-    MASS
+    MASS,
+    methods
 Depends:
     R (>= 3.5.0)
 LazyData: true

NAMESPACE

@@ -10,6 +10,7 @@ S3method(coef,cond_indirect_diff)
 S3method(coef,cond_indirect_effects)
 S3method(coef,indirect)
 S3method(coef,indirect_list)
+S3method(coef,indirect_proportion)
 S3method(coef,lm_from_lavaan)
 S3method(confint,cond_indirect_diff)
 S3method(confint,cond_indirect_effects)
@@ -25,7 +26,9 @@ S3method(print,cond_indirect_diff)
 S3method(print,cond_indirect_effects)
 S3method(print,indirect)
 S3method(print,indirect_list)
+S3method(print,indirect_proportion)
 S3method(print,lm_list)
+S3method(print,mc_out)
 S3method(print,summary_lm_list)
 S3method(summary,lm_list)
 S3method(terms,lm_from_lavaan)
@@ -44,11 +47,13 @@ export(fit2mc_out)
 export(gen_mc_est)
 export(get_one_cond_effect)
 export(get_one_cond_indirect_effect)
+export(get_prod)
 export(index_of_mome)
 export(index_of_momome)
 export(indirect_effect)
 export(indirect_effects_from_list)
 export(indirect_i)
+export(indirect_proportion)
 export(lm2boot_out)
 export(lm2boot_out_parallel)
 export(lm2list)

NEWS.md

@@ -1,4 +1,4 @@
-# manymome 0.1.9.7
+# manymome 0.1.9.15
 
 - Updated badges in README.md. (0.1.9.1)
 - Updated pkgdown site. (0.1.9.2)
@@ -13,6 +13,15 @@
   in Asparouhov and Muthén (2021) if bootstrapping
   confidence interval is requested. By
   default, *p*-values are not printed. (0.1.9.7)
+- Added initial support for models fitted by `runMI()` or `sem.mi()`
+  from the `semTools` package using multiple imputation. (0.1.9.8-0.1.9.10)
+- Added progress bars to `do_mc()`. (0.1.9.11)
+- Added `indirect_proportion()` and two methods for its output. (0.1.9.12)
+- Exported `get_prod()` and added an article on its workflow. (0.1.9.13)
+- Added `print.mc_out()`, the print-method for `mc_out`-class objects. (0.1.9.14)
+- Updated vignettes with package name. (0.1.9.15)
+- Fixed typos in NEWS.md. (0.1.9.15)
+- Updated pkgdown GitHub action for using newer version of mermaid. (0.1.9.15)
 
 # manymome 0.1.9
 

R/all_indirect_paths.R

@@ -104,6 +104,9 @@ all_indirect_paths <- function(fit = NULL,
     if (identical(fit_type, "lavaan")) {
         beta <- lavaan::lavInspect(fit)$beta
       }
+    if (identical(fit_type, "lavaan.mi")) {
+        beta <- lavaan::lavInspect(fit)$beta
+      }
     if (identical(fit_type, "lm")) {
         beta <- beta_from_lm(fit)
       }

R/boot2est_lavaan.R

@@ -319,26 +319,96 @@ boot2implied <- function(fit) {
 # Convert set the estimates in a parameter estimates tables.
 #' @noRd
 
-set_est_i <- function(est0, fit, p_free) {
+set_est_i <- function(est0, fit, p_free, est_df = NULL) {
+    type <- NA
+    if (inherits(fit, "lavaan")) {
+        type <- "lavaan"
+      }
+    if (inherits(fit, "lavaan.mi")) {
+        type <- "lavaan.mi"
+      }
+    if (isTRUE(is.na(type))) {
+        stop("Object is not of a supported type.")
+      }
+    out <- switch(type,
+                  lavaan = set_est_i_lavaan(est0 = est0,
+                                            fit = fit,
+                                            p_free = p_free,
+                                            est_df = est_df),
+                  lavaan.mi = set_est_i_lavaan_mi(est0 = est0,
+                                                  fit = fit,
+                                                  p_free = p_free,
+                                                  est_df = est_df))
+    out
+  }
+
+
+#' @noRd
+
+set_est_i_lavaan <- function(est0, fit, p_free, est_df = NULL) {
+    fit@ParTable$est[p_free] <- unname(est0)
+    ptable <- as.data.frame(fit@ParTable)
+    if (!is.null(est_df)) {
+        est_df$est <- NULL
+        est0 <- merge(est_df, ptable[, c("lhs", "op", "rhs", "est")],
+                      sort = FALSE)
+        class(est0) <- class(est_df)
+        return(est0)
+      } else {
+        est0 <- lavaan::parameterEstimates(fit,
+                                          se = FALSE,
+                                          zstat = FALSE,
+                                          pvalue = FALSE,
+                                          ci = FALSE,
+                                          rsquare = FALSE,
+                                          remove.eq = FALSE,
+                                          remove.ineq = FALSE,
+                                          remove.def = FALSE,
+                                          remove.nonfree = FALSE,
+                                          remove.step1 = FALSE)
+        return(est0)
+      }
+  }
+
+#' @noRd
+
+set_est_i_lavaan_mi <- function(est0, fit, p_free, est_df = NULL) {
     fit@ParTable$est[p_free] <- unname(est0)
-    est0 <- lavaan::parameterEstimates(fit,
-                                       se = FALSE,
-                                       zstat = FALSE,
-                                       pvalue = FALSE,
-                                       ci = FALSE,
-                                       rsquare = TRUE,
-                                       remove.eq = FALSE,
-                                       remove.ineq = FALSE,
-                                       remove.def = FALSE,
-                                       remove.nonfree = FALSE,
-                                       remove.step1 = FALSE)
+    est0 <- lav_est(fit,
+                    se = FALSE,
+                    ci = FALSE,
+                    est_df = est_df)
     est0
   }
 
 # Get the implied statistics from a set of estimates
 #' @noRd
 
-get_implied_i <- function(est0, fit) {
+
+get_implied_i <- function(est0, fit, fit_tmp = NULL) {
+    type <- NA
+    if (inherits(fit, "lavaan")) {
+        type <- "lavaan"
+      }
+    if (inherits(fit, "lavaan.mi")) {
+        type <- "lavaan.mi"
+      }
+    if (isTRUE(is.na(type))) {
+        stop("Fit is not of a supported type.")
+      }
+    out <- switch(type,
+                  lavaan = get_implied_i_lavaan(est0 = est0,
+                                                fit = fit,
+                                                fit_tmp = fit_tmp),
+                  lavaan.mi = get_implied_i_lavaan_mi(est0 = est0,
+                                                      fit = fit,
+                                                      fit_tmp = fit_tmp))
+    out
+  }
+
+#' @noRd
+
+get_implied_i_lavaan <- function(est0, fit, fit_tmp = NULL) {
     has_lv <- length(lavaan::lavNames(fit, "lv")) != 0
     if (has_lv) {
         p_free <- fit@ParTable$free > 0
@@ -369,7 +439,11 @@ get_implied_i <- function(est0, fit) {
     out1 <- out
     for (x in out_names) {
         if (x %in% implied_names) {
-          out1[[x]][] <- implied[[x]][[1]]
+          if (!is.null(implied[[x]][[1]])) {
+              out1[[x]][] <- implied[[x]][[1]]
+            } else {
+              out1[[x]][] <- NA
+            }
         } else {
           out1[[x]][] <- NA
         }
@@ -380,6 +454,73 @@ get_implied_i <- function(est0, fit) {
     out1
   }
 
+#' @noRd
+
+get_implied_i_lavaan_mi <- function(est0, fit, fit_tmp = NULL) {
+    if (is.null(fit_tmp)) {
+        fit_tmp <- methods::new("lavaan",
+                      version = as.character(utils::packageVersion("lavaan")))
+        fit_tmp@Model <- fit@Model
+        fit_tmp@Data <- fit@Data
+        fit_tmp@ParTable <- fit@ParTableList[[1]]
+        fit_tmp@pta <- fit@pta
+        fit_tmp@Options <- fit@Options
+      }
+    has_lv <- length(lavaan::lavNames(fit, "lv")) != 0
+    if (has_lv) {
+        p_free <- fit_tmp@ParTable$free > 0
+        fit_tmp@ParTable$est[p_free] <- unname(est0)
+        fit_tmp@Model@GLIST <- lavaan::lav_model_set_parameters(fit_tmp@Model,
+                                                                est0)@GLIST
+        implied_cov_all <- lavaan::lavInspect(fit_tmp, "cov.all")
+        mod0 <- lavaan::lav_model_set_parameters(fit_tmp@Model, est0)
+        # implied_mean_ov <- lavaan::lavInspect(fit_tmp, "mean.ov")
+        implied_mean_ov <- lavaan::lav_model_implied(mod0,
+                                             GLIST = NULL,
+                                             delta = TRUE)$mean[[1]][, 1]
+        names(implied_mean_ov) <- lavaan::lavNames(fit_tmp, "ov")
+        class(implied_mean_ov) <- c("lavaan.vector", class(implied_mean_ov))
+        implied_mean_lv <- lavaan::lavInspect(fit_tmp, "mean.lv")
+        implied_mean_lv[] <- NA
+        implied <- list(cov = list(implied_cov_all),
+                        mean = list(c(implied_mean_ov,
+                                      implied_mean_lv)),
+                        mean_lv = list(implied_mean_lv))
+      } else {
+        mod0 <- lavaan::lav_model_set_parameters(fit_tmp@Model, est0)
+        implied <- lavaan::lav_model_implied(mod0,
+                                             GLIST = NULL,
+                                             delta = TRUE)
+      }
+    tmpnames1 <- c(lavaan::lavNames(fit_tmp, "ov"),
+                   lavaan::lavNames(fit_tmp, "lv"))
+    tmpnames2 <- lavaan::lavNames(fit_tmp, "lv")
+    out <- list(cov = lav_implied_all(fit_tmp)$cov,
+                mean = stats::setNames(rep(as.numeric(NA), length(tmpnames1)),
+                                tmpnames1))
+    if (has_lv) {
+        tmp <- stats::setNames(rep(as.numeric(NA), length(tmpnames2)),
+                        tmpnames2)
+        class(tmp) <- c("lavaan.vector", class(tmp))
+        out$mean_lv <- tmp
+      }
+    out_names <- names(out)
+    implied_names <- names(implied)
+    out1 <- out
+    for (x in out_names) {
+        if (x %in% implied_names) {
+          if (!is.null(implied[[x]][[1]])) {
+              out1[[x]][] <- implied[[x]][[1]]
+            } else {
+              out1[[x]][] <- NA
+            }
+        } else {
+          out1[[x]][] <- NA
+        }
+      }
+    out1
+  }
+
 # Create the function for bootstrapping.
 # Return the parameter estimates and implied statistics.
 #' @noRd

R/check_path.R

@@ -93,7 +93,8 @@ check_path <- function(x,
       fit_type <- cond_indirect_check_fit(fit)
       est <- switch(fit_type,
               lm = lm2ptable(fit)$est,
-              lavaan = lavaan::parameterEstimates(fit))
+              lavaan = lav_est(fit, se = FALSE, ci = FALSE),
+              lavaan.mi = lav_est(fit, se = FALSE, ci = FALSE))
     }
     if (is.null(m)) {
         return(any(((est$lhs == y) & (est$op == "~") & (est$rhs == x))))

R/cond_indirect.R

@@ -538,6 +538,12 @@ cond_indirect <- function(x,
         if (is.null(implied_stats)) implied_stats <- lav_implied_all(fit)
         fit_data <- lavaan::lavInspect(fit, "data")
       }
+    if (fit_type == "lavaan.mi") {
+        fit0 <- fit
+        if (is.null(est)) est <- lav_est(fit)
+        if (is.null(implied_stats)) implied_stats <- lav_implied_all(fit)
+        fit_data <- lav_data_used(fit, drop_colon = FALSE)
+      }
     if (fit_type == "lm") {
         fit0 <- NULL
         lm_est <- lm2ptable(fit)
@@ -1079,6 +1085,9 @@ cond_indirect_check_fit <- function(fit) {
             stop("'fit' is a list but not all the elements are lm outputs.")
           }
       }
+    if (inherits(fit, "lavaan.mi")) {
+        fit_type <- "lavaan.mi"
+      }
     if (is.na(fit_type)) {
         stop("'fit' is neither a lavaan object or a list of lm outputs.")
       }

R/do_boot.R

@@ -129,6 +129,9 @@ do_boot <- function(fit,
                     make_cluster_args = list(),
                     progress = TRUE) {
     fit_type <- cond_indirect_check_fit(fit)
+    if (fit_type == "lavaan.mi") {
+        stop("Bootstrapping does not support multiple imputation.")
+      }
     if (fit_type == "lavaan") {
         fit_boot <- tryCatch(lavaan::lavInspect(fit, "boot"),
                              error = function(e) e)

R/do_mc.R

@@ -67,8 +67,8 @@
 #' @param make_cluster_args Not used. Kept
 #' for compatibility with [do_boot()].
 #'
-#' @param progress Not used. Kept
-#' for compatibility with [do_boot()].
+#' @param progress Logical. Display
+#' progress or not. Default is `TRUE`.
 #'
 #' @seealso [fit2mc_out()], which
 #' implements the Monte Carlo simulation.
@@ -116,11 +116,11 @@ do_mc <- function(fit,
                     make_cluster_args = list(),
                     progress = TRUE) {
     fit_type <- cond_indirect_check_fit(fit)
-    if (fit_type == "lavaan") {
+    if (fit_type == "lavaan" || fit_type == "lavaan.mi") {
         fit0 <- gen_mc_est(fit = fit,
                           seed = seed,
                           R = R)
-        out <- fit2mc_out(fit0)
+        out <- fit2mc_out(fit0, progress = progress)
       }
     if (fit_type == "lm") {
         stop("Monte Carlo method does not support lm outputs.")
@@ -140,8 +140,10 @@ do_mc <- function(fit,
 gen_mc_est <- function(fit,
                        R = 100,
                        seed = NULL) {
-    fit_vcov <- tryCatch(lavaan::lavInspect(fit, "vcov"),
-                            error = function(e) e)
+    # fit_vcov <- tryCatch(lavaan::lavInspect(fit, "vcov"),
+    #                         error = function(e) e)
+    fit_vcov <- tryCatch(get_vcov(fit),
+                         error = function(e) e)
       if (inherits(fit_vcov, "error")) {
           stop("Monte Carlo method cannot be used. VCOV of estimates not available.")
         }