added tests for control object

code cleanup

NAMESPACE

@@ -32,6 +32,7 @@ S3method(strip,semforest)
 S3method(strip,semtree)
 S3method(summary,semforest)
 S3method(summary,semtree)
+S3method(toLatex,semtree)
 export(biodiversity)
 export(diversityMatrix)
 export(evaluateTree)

NEWS.md

@@ -2,14 +2,14 @@
 
 - added an error handler for score-based tests when the vcov matrix cannot be computed (e.g., models with Heywood cases)
 - leaner package imports: removed dependency on bitops and stringr package
-- prefer `semforest_control()` over `semforest.control()`
+- prefer `semforest_control()` over `semforest.control()` and `semtree_control()` over `semtree.control()`
 - added heuristics for choosing `mtry` in forests (if `NULL`) and for choosing `min.N` and `min.bucket` (if `NULL`)
-- moved dependency on ctsemOMX to suggested package
+- moved dependency on `ctsemOMX` to suggested package
 
 # semtree 0.9.19 (2023)
 
-- changed default behavior of print function of varimp, such that na.omit=TRUE, which is consistent with other packages like party or partykit
-- fixed issues with toTable()-command, by default, all parameters are shown now, also fixed a bug with score-based tests and toTable()
+- changed default behavior of print function of `varimp`, such that na.omit=TRUE, which is consistent with other packages like party or partykit
+- fixed issues with `toTable()`-command, by default, all parameters are shown now, also fixed a bug with score-based tests and toTable()
 - fixed problem with focus-parameters and variable importance
 - bugfix in score-based tests that sometimes did not respect min.N constraints
 - new functionality for parameter contribution evaluation

R/npar.R

@@ -1,6 +1,6 @@
 npar <- function(x) {
   if (is(x, "OpenMx") || is(x, "MxRAMModel")) {
-    summary(x)$estimatedParameters
+    length(OpenMx:::omxGetParameters(x))
   } else if (is(x, "ctsemFit")) {
     stop("npar() not implemented yet for ctsemFit")
   } else if (is(x, "lavaan")) {

R/semforest.R

@@ -117,7 +117,7 @@ semforest <- function(model,
   # set mtry heuristically if not set manually
   if (is.null(semforest.control$mtry)) {
     num_covariates <- length(covariate.ids)
-    mtry <- ceil(sqrt(num_covariates))
+    mtry <- ceiling(sqrt(num_covariates))
     ui_message("Setting mtry = ",mtry," based on ",num_covariates," predictors.\n")
   }
 

R/semtree.control.R

@@ -17,7 +17,7 @@
 #' implements modern score-based statistics.
 #' 
 #' 
-#' @aliases semtree.control print.semtree.control
+#' @aliases semtree.control print.semtree.control semtree_control
 #' @param method Default: 'naive'. One out of
 #' \code{c("score","fair","naive")} for either an unbiased two-step
 #' selection algorithm,  a naive take-the-best, or a
@@ -199,3 +199,10 @@ semtree.control <-
 
     return(options)
   }
+
+
+
+#' @export
+semtree_control <- function(...) {
+  semtree.control(...)
+}

R/toLatex.semtree.R

@@ -1,3 +1,8 @@
+#toLatex <- function(object, ... ) UseMethod("toLatex")
+
+#toLatex.default <- utils::toLatex
+
+#' @exportS3Method toLatex semtree
 toLatex.semtree <-
 function(object, alternative.edge.labels=TRUE,root=NULL,
 	 prev_node=NULL, latex.mapping=NULL,parameter.names=NULL, stars=FALSE, linewidth=1,

tests/control.R

@@ -0,0 +1,83 @@
+require(semtree)
+
+
+data(lgcm)
+
+lgcm$agegroup <- ordered(lgcm$agegroup, labels=c("young","old") )
+lgcm$training <- as.factor(lgcm$training)
+lgcm$noise <- as.factor(lgcm$noise)
+
+# LOAD IN OPENMX MODEL.
+# A SIMPLE LINEAR GROWTH MODEL WITH 5 TIME POINTS FROM SIMULATED DATA
+
+manifests <- names(lgcm)[1:5]
+lgcModel <- mxModel("Linear Growth Curve Model Path Specification",
+                    type="RAM",
+                    manifestVars=manifests,
+                    latentVars=c("intercept","slope"),
+                    # residual variances
+                    mxPath(
+                      from=manifests,
+                      arrows=2,
+                      free=TRUE,
+                      values = c(1, 1, 1, 1, 1),
+                      labels=c("residual1","residual2","residual3","residual4","residual5")
+                    ),
+                    # latent variances and covariance
+                    mxPath(
+                      from=c("intercept","slope"),
+                      connect="unique.pairs",
+                      arrows=2,
+                      free=TRUE,
+                      values=c(1, 1, 1),
+                      labels=c("vari", "cov", "vars")
+                    ),
+                    # intercept loadings
+                    mxPath(
+                      from="intercept",
+                      to=manifests,
+                      arrows=1,
+                      free=FALSE,
+                      values=c(1, 1, 1, 1, 1)
+                    ),
+                    # slope loadings
+                    mxPath(
+                      from="slope",
+                      to=manifests,
+                      arrows=1,
+                      free=FALSE,
+                      values=c(0, 1, 2, 3, 4)
+                    ),
+                    # manifest means
+                    mxPath(
+                      from="one",
+                      to=manifests,
+                      arrows=1,
+                      free=FALSE,
+                      values=c(0, 0, 0, 0, 0)
+                    ),
+                    # latent means
+                    mxPath(
+                      from="one",
+                      to=c("intercept", "slope"),
+                      arrows=1,
+                      free=TRUE,
+                      values=c(1, 1),
+                      labels=c("meani", "means")
+                    ),
+                    mxData(lgcm,type="raw")
+)
+
+
+# TREE CONTROL OPTIONS.
+# TO OBTAIN BASIC/DEFAULT SMETREE OPTIONS, SIMPLY TPYE THE FOLLOWING:
+
+controlOptions <- semtree.control(method = "naive",max.depth = 0,min.N=NULL,
+                                  min.bucket=NULL)
+
+# RUN TREE.
+
+tree <- semtree(model=lgcModel, data=lgcm, control = controlOptions)
+
+stopifnot(tree$control$min.N==50)
+stopifnot(tree$control$min.bucket==25)

tests/lavaan.R

@@ -15,7 +15,7 @@ data(lgcm)
 
 lgcm$agegroup <- as.ordered(lgcm$agegroup)
 lgcm$training <- as.factor(lgcm$training)
-lgcm$noise <- as.numeric(lgcm$noise)
+lgcm$noise <- as.factor(lgcm$noise)
 
 # LOAD IN LAVAAN MODEL.
 # A SIMPLE LINEAR GROWTH MODEL WITH 5 TIME POINTS FROM SIMULATED DATA
@@ -37,7 +37,7 @@ lgcModel <- lavaan(lgcModelstr, lgcm, do.fit=TRUE)
 # TREE CONTROL OPTIONS.
 # TO OBTAIN BASIC/DEFAULT SMETREE OPTIONS, SIMPLY TPYE THE FOLLOWING:
 
-controlOptions <- semtree.control()
+controlOptions <- semtree.control(method="score")
 
 # THE CONTENTS OF THE DEFAULT CONTROLS CAN THEN BE VIEWED.
 
@@ -92,6 +92,4 @@ treeSub <- subtree(tree, startNode=3)
 controlOptions$method <- "fair"
 tree2 <- semtree(model=lgcModel, data=lgcm, control = controlOptions)
 
-# disabled for time restrictions on CRAN
-#controlOptions$method <- "cv"
-#tree3 <- semtree(model=lgcModel, data=lgcm, control = controlOptions)
+toTable(tree2)

tests/testthat/test-semtree_control.R

@@ -6,3 +6,23 @@ testthat::test_that("control object is created and checked correctly", {
   chck <- semtree:::check.semtree.control(ctrl)
   expect_true(chck)
 }  )
+
+
+testthat::test_that("", {
+
+  library(semtree)
+  library(lavaan)
+
+  n <- 1000
+
+  x <- rnorm(n)
+
+  # data frame has only a dummy predictor
+  df <- data.frame(x=x)
+
+  fit <- lavaan("x~~x",df)
+
+  ctrl <- semforest_control(mtry=NULL)
+
+  semforest(model, data, control=ctrl)
+})