Merge branch 'develop' of github.com:sem-in-r/seminr into develop

NAMESPACE

@@ -34,6 +34,7 @@ S3method(summary,seminr_model)
 export(PLSc)
 export(as.reflective)
 export(associations)
+export(boot_paths_df)
 export(bootstrap_model)
 export(browse_plot)
 export(check_test_plot)

R/boot_utils.R

@@ -0,0 +1,41 @@
+#' Return all path bootstraps as a long dataframe.
+#' Columns of the dataframes are specified paths and rows are the estimated
+#' coefficients for the paths at each bootstrap iteration.
+#'
+#' @param pls_boot bootstrapped PLS model
+#'
+#' @examples
+#' data(mobi)
+#'
+#' mobi_mm <- constructs(
+#'   composite("Image",        multi_items("IMAG", 1:5)),
+#'   composite("Expectation",  multi_items("CUEX", 1:3)),
+#'   composite("Satisfaction", multi_items("CUSA", 1:3))
+#' )
+#'
+#' mobi_sm <- relationships(
+#'   paths(from = c("Image", "Expectation"), to = "Satisfaction")
+#' )
+#'
+#' pls_model <- estimate_pls(data = mobi,
+#'                           measurement_model = mobi_mm,
+#'                           structural_model = mobi_sm)
+#'
+#' pls_boot <- bootstrap_model(seminr_model = pls_model,
+#'                             nboot = 50, cores = 2, seed = NULL)
+#'
+#' boot_paths_df(pls_boot)
+#'
+#' @export
+boot_paths_df <- function(pls_boot) {
+  path_names <- apply(pls_boot$smMatrix, 1, \(path) {
+    paste(path['source'], '->', path['target'])
+  })
+
+  boot_paths <- apply(pls_boot$smMatrix, 1, \(path) {
+    pls_boot$boot_paths[path['source'], path['target'], 1:pls_boot$boots]
+  })
+
+  colnames(boot_paths) <- path_names
+  boot_paths
+}

R/compute_safe.R

@@ -0,0 +1,11 @@
+#' Standardize (scale) a matrix/df and report interpretable errors
+#'
+#' @param x vector, data.frame, or matrix
+#' @return scaled object as returned by \code{scale} function
+standardize_safely <- function(x) {
+  # NOTE: we could return zeros for columns with zero variance:
+  # apply(x, 2, function(y) (y - mean(y)) / sd(y) ^ as.logical(sd(y)))
+  res <- scale(x, TRUE, TRUE)
+  if (any(is.nan(res))) stop("zero variance items cannot be scaled")
+  res
+}

R/estimate_factor_scores.R

@@ -38,8 +38,8 @@
 #' @export
 estimate_lavaan_ten_berge <- function (fit) {
   X <- lavaan::lavInspect(fit, "data")
-  i.means <- fit@SampleStats@mean[[1]]
-  i.sds <- sqrt(fit@SampleStats@var[[1]])
+  i.means <- colMeans(X)
+  i.sds <- sqrt(diag(lavaan::lavInspect(fit, "sampstat")$cov))
   Lambda_mat <- lavaan::lavInspect(fit, what = "std.lv")$lambda
   Phi_mat <- matrix(lavaan::lavInspect(fit, what = "cor.lv"), ncol(Lambda_mat))
   calc_ten_berge_scores(X, Lambda_mat, Phi_mat, i.means, i.sds)

R/estimate_pls_mga.R

@@ -50,12 +50,6 @@ estimate_pls_mga <- function(pls_model, condition, nboot = 2000, ...) {
     path_coef[path["source"], path["target"]]
   }
 
-  # Get all path estimates of a given beta metrix from a given path_coef matrix
-  # Typically used to apply on 3rd dimension of a 3x3 bootstrap paths array [from,to,boot]
-  boot_paths <- function(path_coef, beta_df) {
-    betas <- apply(beta_df, MARGIN=1, FUN=path_estimate, path_coef = path_coef)
-  }
-
   # Allocate and Estimate Two Alternative Datasets + Models
   group1_data <- pls_data[condition, ]
   group2_data <- pls_data[!condition, ]
@@ -82,11 +76,8 @@ estimate_pls_mga <- function(pls_model, condition, nboot = 2000, ...) {
   beta$diff <- apply(beta, MARGIN = 1, FUN=path_estimate, path_coef = beta_diff)
 
   # Get bootstrapped paths for both groups
-  boot1_betas <- t(apply(group1_boot$boot_paths, MARGIN=3, FUN=boot_paths, beta_df=beta))
-  colnames(boot1_betas) <- path_names
-
-  boot2_betas <- t(apply(group2_boot$boot_paths, MARGIN=3, FUN=boot_paths, beta_df=beta))
-  colnames(boot2_betas) <- path_names
+  boot1_betas <- boot_paths_df(group1_boot)
+  boot2_betas <- boot_paths_df(group2_boot)
 
   # PLSc may not resolve in some bootstrap runs - limit bootstrap paths to resolved number of boots
   J <- min(dim(boot1_betas)[1], dim(boot2_betas)[1])

R/estimate_simplePLS.R

@@ -79,7 +79,8 @@ simplePLS <- function(obsData, smMatrix, mmMatrix, inner_weights = path_weightin
   constructs <- construct_names(smMatrix)
 
   #Extract and Normalize the measurements for the model
-  normData <- scale(obsData[, mmVariables], TRUE, TRUE)
+  # normData <- scale(obsData[, mmVariables], TRUE, TRUE)
+  normData <- standardize_safely(obsData[, mmVariables])
 
   #Extract Mean and Standard Deviation of measurements for future prediction
   meanData <- attr(normData, "scaled:center")
@@ -121,7 +122,8 @@ simplePLS <- function(obsData, smMatrix, mmMatrix, inner_weights = path_weightin
     construct_scores <- normData[, mmVariables]%*%outer_weights
 
     #Standardize construct Scores
-    construct_scores <- scale(construct_scores,TRUE,TRUE)
+    # construct_scores <- scale(construct_scores,TRUE,TRUE)
+    construct_scores <- standardize_safely(construct_scores)
 
     #Estimate inner paths using weighting scheme - factorial or path-weighting
     inner_paths <- inner_weights(smMatrix, construct_scores, dependant, paths_matrix)
@@ -130,7 +132,8 @@ simplePLS <- function(obsData, smMatrix, mmMatrix, inner_weights = path_weightin
     construct_scores<-construct_scores%*%inner_paths
 
     #Standarize construct Scores
-    construct_scores <- scale(construct_scores, TRUE, TRUE)
+    #construct_scores <- scale(construct_scores, TRUE, TRUE)
+    construct_scores <- standardize_safely(construct_scores)
 
     #Save last outer_weights
     last_outer_weights <- outer_weights
@@ -187,4 +190,3 @@ simplePLS <- function(obsData, smMatrix, mmMatrix, inner_weights = path_weightin
   class(plsModel) <- "simple_pls_model"
   return(plsModel)
 }
-

R/report_lavaan.R

@@ -6,7 +6,7 @@ summarize_cb_measurement <- function(object, alpha=0.05) {
   model <- list(
     item_names       = all_items(object$measurement_model),
     construct_names  = all_construct_names(object$measurement_model),
-    estimation       = lavaan_output@Model@estimator
+    estimation       = lavaan::lavInspect(lavaan_output, "options")$estimator
   )
 
   # Get standardized parameter estimates (won't contain R^2)
@@ -29,8 +29,8 @@ summarize_cb_measurement <- function(object, alpha=0.05) {
       seminr = seminr_info(),
       engine = list(
         pkgname = "lavaan",
-        version = lavaan_output@version,
-        estimator = lavaan_output@Options$estimator
+        version = lavaan::lavInspect(lavaan_output, "version"),
+        estimator = lavaan::lavInspect(lavaan_output, "options")$estimator
       ),
       syntax  = object$lavaan_model,
       call    = lavaan_output@call