Refactor moderation probe syntax

R/bayesianProcess.R

@@ -103,11 +103,15 @@ BayesianProcess <- function(jaspResults, dataset = NULL, options) {
   nuPrior   <- sprintf("normal(%s,%s)", options$nuPriorMu, options$nuPriorSigma)
   betaPrior <- sprintf("normal(%s,%s)", options$betaPriorMu, options$betaPriorSigma)
   psiPrior  <- sprintf("gamma(%s,%s)[sd]", options$psiPriorAlpha, options$psiPriorBeta)
-  rhoPrior  <- sprintf("beta(%s,%s)[sd]", options$rhoPriorAlpha, options$rhoPriorBeta)
+  rhoPrior  <- sprintf("beta(%s,%s)", options$rhoPriorAlpha, options$rhoPriorBeta)
   return(blavaan::dpriors(nu = nuPrior, beta = betaPrior, psi = psiPrior, rho = rhoPrior))
 }
 
 .procBayesResultsFitModel <- function(container, dataset, options, modelOptions) {
+  # Somehow the future.apply dependency of blavaan changes this option globally to NULL
+  # which throws an error; thus we change it locally
+  rlang::local_options(future.globals.method.default = "ordered")
+
   # Check if graph has error message
   if (!.procCheckGraph(container[["graph"]]$object) && jaspBase::isTryError(container[["graph"]]$object)) {
     return(.procEstimationMsg(container[["graph"]]$object))
@@ -152,7 +156,7 @@ BayesianProcess <- function(jaspResults, dataset = NULL, options) {
   }
 
   if (jaspBase::isTryError(fittedModel)) {
-    return(.procLavaanMsg(fittedModel))
+    return(.procEstimationMsg())
   }
 
   return(fittedModel)

R/classicProcess.R

@@ -958,42 +958,33 @@ ClassicProcess <- function(jaspResults, dataset = NULL, options) {
   return(modOut)
 }
 
-.procMedEffectsSyntaxModPars <- function(pathEdge, sourceNode, contrFacVars, graph, modProbes) {
+.procMedEffectsSyntaxModPars <- function(pathEdge, sourceNode, contrFacVars, graph) {
   # Get moderator parameters for two-way interactions
   modPars <- lapply(pathEdge$modVars[[1]], function(v) {
     # Get edge for two way interaction between X and M
     twoWayEdge <- igraph::E(graph)[paste(sourceNode, v, sep = "__") %--% pathEdge$target]$parName
 
-    # Concatenate two way edge parName with moderator probes
-    return(apply(expand.grid(
-      twoWayEdge,
-      format(modProbes[[v]], digits = 3)
-    ), 1, paste, collapse = "*"))
+    # Concatenate two way edge parName with moderator
+    return(paste(twoWayEdge, v, sep = "*"))
   })
 
   # Concatenate dummy variables for factor moderators
   modPars <- .procMedEffectsSyntaxMergeFacMods(pathEdge$modVars[[1]], contrFacVars, modPars, sep = " + ")
 
-  # Get all possible combinations of probes from different moderators
-  modPars <- apply(expand.grid(modPars), 1, paste, collapse = " + ")
-
   # Get name of potential three-way interaction
   threeWayInt <- paste(c(pathEdge$source, pathEdge$modVars[[1]]), collapse = "__")
 
   if (length(pathEdge$modVars[[1]]) > 1 && threeWayInt %in% igraph::E(graph)$source) { # If three-way int
     # Get edge of three way interaction X x M1 x M2
     threeWayEdge <- igraph::E(graph)[threeWayInt %--% pathEdge$target]
-    # Combine three way int parName with moderator probes
+    # Combine three way int parName with moderator
     threeWayModPars <- paste(
       threeWayEdge$parName,
-      apply(
-        expand.grid(lapply(pathEdge$modVars[[1]], function(v) format(modProbes[[v]], digits = 3))),
-        1, paste, collapse = "*"
-      ),
+      paste(pathEdge$modVars[[1]], collapse = "*"),
       sep = "*"
     )
-    # Add to previous moderator probes
-    modPars <- paste(modPars, threeWayModPars, sep = "+")
+    # Add to previous moderator terms
+    modPars <- append(modPars, threeWayModPars)
   }
   return(modPars)
 }
@@ -1067,8 +1058,11 @@ ClassicProcess <- function(jaspResults, dataset = NULL, options) {
     sourceFacVars <- numeric(0)
   }
 
+  rhs <- c()
+  uniqueMods <- c()
+
   # Right hand side of lavaan syntax
-  rhs <- lapply(2:length(path), function(i) {
+  for (i in 2:length(path)) {
     # Get edge from path[-1] to path[i]
     if (any(sourceInContrFacVars) && names(path)[i-1] %in% sourceFacVars) {
       # Get all vars with factor levels as source nodes
@@ -1081,24 +1075,141 @@ ClassicProcess <- function(jaspResults, dataset = NULL, options) {
     # Edge from previous node to current node
     pathEdge <- igraph::E(graph)[sourceNode %--% names(path)[i]]
 
+    modVars <- unlist(pathEdge$modVars)
+
     # If no moderators on edge, return only parName
-    if(any(is.na(unlist(pathEdge$modVars)))) return(pathEdge$parName)
+    if(any(is.na(modVars))) {
+      pathEdgeRhs <- pathEdge$parName
 
-    # Get pars from moderators
-    modPars <- .procMedEffectsSyntaxModPars(pathEdge, sourceNode, contrFacVars, graph, modProbes)
-
-    # If indirect path add parentheses
-    if (i > 1) {
-      return(paste0("(", pathEdge$parName, " + ", modPars, ")"))
+      if (length(rhs) > 0) {
+        # Multiply effects on indirect paths
+        rhs <- paste(rhs, pathEdgeRhs, sep = "*")
+      } else {
+        rhs <- pathEdgeRhs
+      }
+    } else {
+      # Get pars from moderators
+      modPars <- .procMedEffectsSyntaxModPars(pathEdge, sourceNode, contrFacVars, graph)
+
+      # Get sum of moderator terms
+      modPars <- .doCallPaste(modPars, sep = " + ")
+
+      # If indirect path add parentheses
+      if (i > 1) {
+        pathEdgeRhs <- paste0("(", pathEdge$parName, " + ", unlist(modPars), ")")
+      } else {
+        pathEdgeRhs <- paste(pathEdge$parName, unlist(modPars), sep = " + ")
+      }
+
+      if (length(rhs) > 0) {
+        # Get all possible combinations with new moderators
+        if (all(!modVars %in% uniqueMods)) {
+          rhs <- apply(expand.grid(rhs, pathEdgeRhs), 1, paste, collapse = "*")
+        } else {
+          rhs <- paste(rhs, pathEdgeRhs, sep = "*")
+        }
+      } else {
+        rhs <- pathEdgeRhs
+      }
+      uniqueMods <- unique(c(uniqueMods, modVars))
     }
-    # Concanenate path edge parName with moderator probes
-    return(paste(pathEdge$parName, modPars, sep = " + "))
-  })
-
-  # If indirect paths, multiply their steps
-  rhs <- .doCallPaste(rhs, sep = "*")
+  }
 
-  return(rhs)
+  modProbes <- modProbes[uniqueMods]
+
+  # Substitute moderator variables with probe values
+  rhsProbes <- c()
+
+  if (any(sourceInContrFacVars) && length(modProbes) > 0) {
+    # Identify which modProbes are factor dummies
+    modIdx <- sapply(names(modProbes), function(nm) {
+      idx <- which(sapply(contrFacVars, function(fac) nm %in% fac))
+
+      if (length(idx) == 0) return(FALSE)
+
+      return(idx)
+    })
+    # Remove non-factor moderators that have index zero
+    facModIdx <- modIdx[modIdx > 0]
+
+    facProbeList <- list()
+    facGroups <- list()
+    if (any(facModIdx)) {
+      # Group factor dummies by factor (with >2 levels)
+      facGroups <- contrFacVars[unique(facModIdx)]
+      names(facGroups) <- as.character(unique(facModIdx))
+      # Concatenate levels of the same factor
+      facProbeList <- lapply(facGroups, function(grp) {
+        probes <- Reduce(cbind, modProbes[grp])
+
+        if (is.null(dim(probes))) return(probes)
+
+        return(apply(probes, 1, paste, collapse = "_"))
+      })
+    }
+    # Now, collect all non-factor moderators
+    nonFacMods <- names(modProbes)[modIdx == 0]
+    nonFacProbeList <- modProbes[nonFacMods]
+    # Combine all for expansion
+    expandList <- c(facProbeList, nonFacProbeList)
+    modGrid <- expand.grid(expandList, stringsAsFactors = FALSE)
+    # Assign column names for substitution
+    colNames <- c(names(facProbeList), nonFacMods)
+    colnames(modGrid) <- colNames
+
+    # Split concatenated factor columns back into original dummy columns
+    if (length(facProbeList) > 0) {
+      for (k in 1:length(facProbeList)) {
+        facCol <- names(facProbeList)[k]
+        # Get the original dummy variable names for this factor
+        origDummies <- facGroups[[facCol]]
+        if (length(origDummies) == 1) {
+          splitVals <- matrix(modGrid[[facCol]], ncol = 1)
+        } else {
+          # Split the concatenated string into separate columns
+          splitVals <- do.call(rbind, strsplit(modGrid[[facCol]], "_", fixed = TRUE))
+          # If only one dummy, keep as vector
+        }
+
+        # Assign columns with original dummy names
+        for (d in 1:length(origDummies)) {
+          modGrid[[origDummies[d]]] <- splitVals[, d]
+        }
+        # Remove the concatenated column
+        modGrid[[facCol]] <- NULL
+      }
+    }
+
+    for (j in 1:nrow(modGrid)) { # Probe combinations
+      for (i in 1:length(rhs)) { # Path edges
+        rowRhs <- rhs[i]
+        # Replace factor dummies as a group
+        for (p in 1:ncol(modGrid)) {
+          rowRhs <- gsub(colnames(modGrid)[p], format(modGrid[j, p], digits = 3), rowRhs)
+        }
+        rhsProbes <- c(rhsProbes, rowRhs)
+      }
+    }
+  } else {
+    # Default: iterate over rhs first, then probes
+    for (i in 1:length(rhs)) { # Path edges
+      modInPath <- sapply(names(modProbes), function(v) grepl(v, rhs[i]))
+      if (any(modInPath)) {
+        modGrid <- expand.grid(modProbes[modInPath])
+        for (j in 1:nrow(modGrid)) { # Probe combinations
+          rowRhs <- rhs[i]
+          for (p in 1:ncol(modGrid)) { # Moderator vars
+            rowRhs <- gsub(colnames(modGrid)[p], format(modGrid[j, p], digits = 3), rowRhs)
+          }
+          rhsProbes <- c(rhsProbes, rowRhs)
+        }
+      } else {
+        rhsProbes <- c(rhsProbes, rhs[i])
+      }
+    }
+  }
+
+  return(rhsProbes)
 }
 
 .procMedEffectsSyntaxSinglePath <- function(path, graph, modProbes, contrasts) {
@@ -1490,7 +1601,7 @@ ClassicProcess <- function(jaspResults, dataset = NULL, options) {
 .procResultsFitModel <- function(container, dataset, options, modelOptions) {
   # Check if graph has error message
   if (!.procCheckGraph(container[["graph"]]$object) && jaspBase::isTryError(container[["graph"]]$object)) {
-    return(.procEstimationMsg())
+    return(jaspBase::.extractErrorMessage(container[["graph"]]$object))
   }
 
   # Should model be fitted?

tests/testthat/test-classic-process-integration-general.R

@@ -1405,7 +1405,7 @@ test_that("Directed acyclic graph error message works", {
   set.seed(1)
   results <- jaspTools::runAnalysis("ClassicProcess", "debug.csv", options)
 
-  refMsg <- jaspProcess:::.procEstimationMsg(jaspProcess:::.procDagMsg())
+  refMsg <- jaspProcess:::.procDagMsg()
 
   msg <- results[["results"]][["parEstContainer"]][["collection"]][["parEstContainer_Model 1"]][["collection"]][["parEstContainer_Model 1_pathCoefficientsTable"]][["error"]][["errorMessage"]]
   expect_equal(msg, refMsg)

tests/testthat/test-classic-process-unit.R

@@ -480,8 +480,8 @@ test_that("Test that .procMedEffectsSyntaxModPars works - no contrasts", {
   pathEdge <- igraph::E(graph)["contGamma" %--% "contNormal"]
   sourceNode <- "contGamma"
 
-  modPars <- jaspProcess:::.procMedEffectsSyntaxModPars(pathEdge, sourceNode, list(), graph, modProbes)
-  expect_equal(modPars, c("c3*0.1", "c3*0.5", "c3*0.9"))
+  modPars <- jaspProcess:::.procMedEffectsSyntaxModPars(pathEdge, sourceNode, list(), graph)
+  expect_equal(modPars, list("c3*contcor2"))
 })
 
 test_that("Test that .procMedEffectsSyntaxModPars works - with contrasts", {
@@ -502,8 +502,8 @@ test_that("Test that .procMedEffectsSyntaxModPars works - with contrasts", {
   pathEdge <- igraph::E(graph)["contGammaA" %--% "contNormal"]
   sourceNode <- "contGammaA"
 
-  modPars <- jaspProcess:::.procMedEffectsSyntaxModPars(pathEdge, sourceNode, contrFacVars, graph, modProbes)
-  expect_equal(modPars, c("c4*0.1", "c4*0.5", "c4*0.9"))
+  modPars <- jaspProcess:::.procMedEffectsSyntaxModPars(pathEdge, sourceNode, contrFacVars, graph)
+  expect_equal(modPars, list("c4*contcor2"))
 })
 
 test_that("Test that .procMedEffectsSyntaxGetLhs works - no contrasts", {