bugfix with crossvalidation for OpenMx

improved lavaan support
brandmaier · Apr 5, 2017 · 6ac518f · 6ac518f
1 parent a4e9af3
commit 6ac518f
Show file tree

Hide file tree

Showing 5 changed files with 24 additions and 6 deletions.
diff --git a/R/crossvalidatedSplit.R b/R/crossvalidatedSplit.R
@@ -12,7 +12,7 @@ crossvalidatedSplit <- function(model=NULL, mydata=NULL, control=NULL,
 
 
 
-	mvars <- length(model@manifestVars)
+	#mvars <- length(model@manifestVars)
 	n.comp <- 0
 
 	LL.btn <- c()
@@ -28,7 +28,8 @@ crossvalidatedSplit <- function(model=NULL, mydata=NULL, control=NULL,
 
 	LL.baseline <- cvLikelihood(model, mydata, NULL, fold_association, NULL, control, invariance)
 
-for(c in (mvars+1):ncol(mydata)) {
+#for(c in (mvars+1):ncol(mydata)) {
+for (c in meta$covariate.ids)  {
 	#case for factored covariates##############################
 	if(is.factor(mydata[,c])) {
 		#unordered factors#####################################

diff --git a/R/cvLikelihood.R b/R/cvLikelihood.R
@@ -24,7 +24,10 @@ cvLikelihood <- function( model, subset1, subset2, fold_association1,fold_associ
       } 
       else {
  			#return(NA)
-        model1 <- mxModel(model,mxData(observed=training_subset1,type="raw"),name=paste("MODEL",fold,sep=" "))
+        ##model1 <- mxModel(model,mxData(observed=training_subset1,type="raw"),
+        #                  name=paste("MODEL",fold,sep=" "))
+        model1 <- mxAddNewModelData(model=model, data=training_subset1, name=paste("MODEL",fold,sep=" "))
+
 			  out1 <- safeRunAndEvaluate(model1,return.model=T)
         ll1 <- evaluateDataLikelihood(out1$model, test_subset1) 			
   	    ll2 <- 0	
@@ -33,7 +36,6 @@ cvLikelihood <- function( model, subset1, subset2, fold_association1,fold_associ
 
 		lrs[fold] <- (ll1+ll2)
   	}
-  	#cat("AVG LL",mean(lrs)," of fold LLs: ", lrs,  "\n")
   	return(mean(lrs,na.rm=T))
 
 }

diff --git a/R/evaluateDataLikelihood.R b/R/evaluateDataLikelihood.R
@@ -1,7 +1,8 @@
 evaluateDataLikelihood <-
 function(model, data, data_type="raw")
 {
-
+  if(inherits(model,"MxModel") || inherits(model,"MxRAMModel")) {
+
 	# this is to trick the strict CRAN check
 	objective <- NULL
 	#
@@ -58,4 +59,9 @@ function(model, data, data_type="raw")
 
 
 		return(result);
+
+
+  } else {
+    stop("The chosen combination of parameters for semtree is not yet supported with lavaan! Please use OpenMx model specification!")
+  }
 }
diff --git a/R/mxAddNewModelData.R b/R/mxAddNewModelData.R
@@ -13,7 +13,7 @@ mxAddNewModelData <- function(model=model, data=data, name="default", ...) {
   } else if(inherits(model,"lavaan")) {
       # must be a matrix it seems...      TODO: needs to be fixed I guess
       model@Data@X[[1]] <- data #as.matrix(data)
-      model@Data@nobs <- dim(data)[1]
+      model@Data@nobs[[1]] <- dim(data)[1]
 #      model@[email protected] 
       return(model)
   } else {

diff --git a/tests/tree.R b/tests/tree.R
@@ -110,3 +110,12 @@ treeSub <- subtree(tree, startNode=3)
 plot(treeSub)
 
 toTable(tree)
+
+
+controlOptions <- semtree.control(method = "fair")
+
+tree2 <- semtree(lgcModel, lgcm, control=controlOptions)
+
+
+controlOptions <- semtree.control(method = "cv")
+tree3 <- semtree(lgcModel, lgcm, control=controlOptions)