Skip to content

Commit

Permalink
Check for observed variables in qml/lms, and throw an error
Browse files Browse the repository at this point in the history
  • Loading branch information
Kss2k committed Oct 24, 2024
1 parent 63b9243 commit 11c786c
Show file tree
Hide file tree
Showing 4 changed files with 142 additions and 73 deletions.
74 changes: 74 additions & 0 deletions R/check_model_da.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,74 @@
checkModel <- function(model, covModel = NULL, method = "lms") {
checkCovModelVariables(covModel = covModel, modelXis = model$info$xis)

checkNodesLms(parTableMain = model$parTable,
parTableCov = covModel$parTable,
nodes = model$quad$m, method = method)

checkOVsInStructuralModel(parTableMain = model$parTable,
parTableCov = covModel$parTable)
NULL
}


checkCovModelVariables <- function(covModel, modelXis) {
if (is.null(covModel$info)) return(NULL) # nothing to check
covModelEtas <- covModel$info$etas
covModelXis <- covModel$info$xis

stopif(!all(c(covModelXis, covModelEtas) %in% modelXis),
"All latent variables in the cov-model must be an ",
"exogenous variable in the main model")
stopif(!all(modelXis %in% c(covModelXis, covModelEtas)),
"All exogenous variables in main model must be ",
"part of the cov-model")
}

checkNodesLms <- function(parTableMain,
parTableCov,
nodes,
method = "lms",
minNodesXiXi = 16,
minNodesXiEta = 32,
minNodesEtaEta = 48) {
if (method != "lms") return(NULL)

parTable <- rbind(parTableMain, parTableCov)

etas <- getEtas(parTable, isLV = TRUE)
xis <- getXis(parTable, etas = etas, isLV = TRUE)
varsInts <- getVarsInts(getIntTermRows(parTable))

nodesXiXi_ok <- TRUE
nodesXiEta_ok <- TRUE
nodesEtaEta_ok <- TRUE

lapply(varsInts, FUN = function(x) {
if (all(x %in% xis)) nodesXiXi_ok <<- nodes >= minNodesXiXi
else if (all(x %in% etas)) nodesEtaEta_ok <<- nodes >= minNodesEtaEta
else if (any(x %in% etas)) nodesXiEta_ok <<- nodes >= minNodesXiEta
else warning2("Unable to classify latent variables in interaction terms")
})

warnif(!nodesXiXi_ok, "It is recommended that you have at least ",
minNodesXiXi, " nodes for interaction effects between ",
"exogenous variables in the lms approach 'nodes = ", nodes, "'")
warnif(!nodesXiEta_ok, "It is recommended that you have at least ",
minNodesXiEta, " nodes for interaction effects between exogenous ",
"and endogenous variables in the lms approach 'nodes = ", nodes, "'")
warnif(!nodesEtaEta_ok, "It is recommended that you have at least ",
minNodesEtaEta, " nodes for interaction effects between endogenous ",
"variables in the lms approach 'nodes = ", nodes, "'")
}


checkOVsInStructuralModel <- function(parTableMain, parTableCov) {
parTable <- rbind(parTableMain, parTableCov)
xisLVs <- getXis(parTable, isLV = TRUE)
xisAll <- getXis(parTable, isLV = FALSE)

stopif(length(xisAll) != length(xisLVs) || !all(xisLVs %in% xisAll),
"Observed variables are not allowed in the structural model in LMS/QML directly. ",
"Please redefine them as latent.\nSee:\n",
" vignette(\"observed_lms_qml\", \"modsem\")")
}
21 changes: 11 additions & 10 deletions R/utils.R
Original file line number Diff line number Diff line change
Expand Up @@ -14,7 +14,7 @@ stopif <- function(cond, ...) {


warnif <- function(cond, ...) {
if (cond) stop2(...)
if (cond) warning2(...)
}


Expand Down Expand Up @@ -75,14 +75,16 @@ getSortedEtas <- function(parTable, isLV = FALSE, checkAny = TRUE) {

getXis <- function(parTable, etas = NULL, isLV = TRUE, checkAny = TRUE) {
if (is.null(etas)) etas <- getEtas(parTable, isLV = isLV)
if (!isLV) {
xis <- unique(parTable[parTable$op != "~1" &
parTable$lhs %in% etas, "rhs"])
} else {
xis <- unique(parTable[parTable$op == "=~" &
!parTable$lhs %in% etas, "lhs"])
# add all LVs which are not etas
xis <- unique(parTable[parTable$op == "=~" & !parTable$lhs %in% etas, "lhs"])

if (!isLV) { # add any other variabels found in structural expressions
xis <- unique(c(xis, parTable[parTable$op == "~" &
!parTable$rhs %in% etas, "rhs"]))
}

xis <- xis[!grepl(":", xis)] # remove interaction terms

stopif(checkAny && !length(xis), "No xis found")
xis
}
Expand All @@ -101,13 +103,12 @@ getOVs <- function(parTable = NULL, model.syntax = NULL) {
select <- parTable$op %in% c("=~", "~", "~~")
vars <- unique(c(parTable$lhs[select], parTable$rhs[select]))

vars[!vars %in% lVs]
vars[!vars %in% lVs & !grepl(":", vars)]
}


getIndsLVs <- function(parTable, lVs) {
measrExprs <- parTable[parTable$op == "=~" &
parTable$lhs %in% lVs, ]
measrExprs <- parTable[parTable$op == "=~" & parTable$lhs %in% lVs, ]
stopif(!NROW(measrExprs), "No measurement expressions found, for", lVs)
lapplyNamed(lVs, FUN = function(lV) measrExprs[measrExprs$lhs == lV, "rhs"],
names = lVs)
Expand Down
71 changes: 8 additions & 63 deletions R/utils_da.R
Original file line number Diff line number Diff line change
Expand Up @@ -76,8 +76,13 @@ getK_NA <- function(omega, labelOmega) {


sortData <- function(data, allIndsXis, allIndsEtas) {
if (!all(c(allIndsXis, allIndsEtas) %in% colnames(data)))
stop2("Missing Observed Variables in Data")
inds <- c(allIndsXis, allIndsEtas)
ovs <- colnames(data)
missing <- inds[!inds %in% ovs]

stopif(!all(inds %in% ovs), "Missing observed variables in data:\n ",
missing)

data[c(allIndsXis, allIndsEtas)]
}

Expand All @@ -95,7 +100,7 @@ castDataNumericMatrix <- function(data) {
warning = function(w) {
warning2("Warning in converting data to numeric: \n", w)
numericData <- suppressWarnings(lapplyDf(data, FUN = as.numeric))
if (anyAllNA(numericData)) stop2("Unable to conver data to type numeric")
stopif(anyAllNA(numericData), "Unable to convert data to type numeric")
numeric
},
error = function(e) {
Expand Down Expand Up @@ -222,66 +227,6 @@ uniqueByVar <- function(df, var) {
}


checkModel <- function(model, covModel = NULL, method = "lms") {
modelXis <- model$info$xis
if (!is.null(covModel$info)) {
covModelEtas <- covModel$info$etas
covModelXis <- covModel$info$xis
if (!all(c(covModelXis, covModelEtas) %in% modelXis)) {
stop2("All latent variables in the cov-model must be an exogenous variable in the main model")
}
if (!all(modelXis %in% c(covModelXis, covModelEtas))) {
stop2("All exogenous variables in main model must be part of the cov-model")
}
}

checkNodesLms(parTable = rbind(model$parTable, covModel$parTable),
nodes = model$quad$m, method = method)
NULL
}


checkNodesLms <- function(parTable,
nodes,
method = "lms",
minNodesXiXi = 16,
minNodesXiEta = 32,
minNodesEtaEta = 48) {
if (method == "qml") return(NULL)

etas <- getEtas(parTable, isLV = TRUE)
xis <- getXis(parTable, etas = etas, isLV = TRUE)
varsInts <- getVarsInts(getIntTermRows(parTable))

nodesXiXi_ok <- TRUE
nodesXiEta_ok <- TRUE
nodesEtaEta_ok <- TRUE

lapply(varsInts, FUN = function(x) {
if (all(x %in% xis)) nodesXiXi_ok <<- nodes >= minNodesXiXi
else if (all(x %in% etas)) nodesEtaEta_ok <<- nodes >= minNodesEtaEta
else if (any(x %in% etas)) nodesXiEta_ok <<- nodes >= minNodesXiEta
else warning2("Unable to classify latent variables in interaction terms")
})

if (!nodesXiXi_ok) {
warning2("It is recommended that you have at least ", minNodesXiXi, " nodes ",
"for interaction effects between exogenous variables in the lms approach ",
"'nodes = ", nodes, "'")
}
if (!nodesXiEta_ok) {
warning2("It is recommended that you have at least ", minNodesXiEta, " nodes ",
"for interaction effects between exogenous and endogenous variables in the lms approach ",
"'nodes = ", nodes, "'")
}
if (!nodesEtaEta_ok) {
warning2("It is recommended that you have at least ", minNodesEtaEta, " nodes ",
"for interaction effects between endogenous variables in the lms approach ",
"'nodes = ", nodes, "'")
}
}


removeInteractionVariances <- function(parTable) {
parTable[!(parTable$op == "~~" &
(grepl(":", parTable$lhs) | grepl(":", parTable$rhs))), ]
Expand Down
49 changes: 49 additions & 0 deletions tests/testthat/test_ovchecks_da.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,49 @@
devtools::load_all()


m1 <- '
# Outer Model
X =~ x1 + x2 +x3
Y =~ y1 + y2 + y3
Z =~ z1 + z2 + z3
# Inner model
Y ~ X + Z + X:Z + x1
'

testthat::expect_error(modsem(m1, oneInt, method = "lms"),
regexp = "Observed variables are not allowed in .*")
testthat::expect_error(modsem(m1, oneInt, method = "qml"),
regexp = "Observed variables are not allowed in .*")


m2 <- '
# Outer Model
X =~ x1 + x2 +x3
Y =~ y1 + y2 + y3
Z =~ z1 + z2 + z3
# Inner model
Y ~ X + Z + X:Z + jk
'

testthat::expect_error(modsem(m2, oneInt, method = "lms"),
regexp = "Observed variables are not allowed in .*")
testthat::expect_error(modsem(m2, oneInt, method = "qml"),
regexp = "Observed variables are not allowed in .*")


m3 <- '
# Outer Model
X =~ x1 + x2 +x3
Y =~ y1 + y2 + y3
Z =~ z1 + z2 + z3 + jk
# Inner model
Y ~ X + Z + X:Z
'

testthat::expect_error(modsem(m3, oneInt, method = "lms"),
regexp = "Missing observed variables in data:.*jk.*")
testthat::expect_error(modsem(m3, oneInt, method = "qml"),
regexp = "Missing observed variables in data:.*jk.*")

0 comments on commit 11c786c

Please sign in to comment.