[Depmix-commits] r187 - in trunk: . R

[noreply at r-forge.r-project.org]

Author: ingmarvisser
Date: 2008-06-25 15:58:37 +0200 (Wed, 25 Jun 2008)
New Revision: 187

Modified:
   trunk/NAMESPACE
   trunk/R/EM.R
   trunk/R/allGenerics.R
   trunk/R/depmixfit-class.R
   trunk/R/depmixfit.R
   trunk/R/freepars.R
Log:
Added function nlin to extract the number of linear constraints in fitted models; to be used in computing the number of free parameters (eg for likelihood testing)

Modified: trunk/NAMESPACE
===================================================================
--- trunk/NAMESPACE	2008-06-24 21:02:54 UTC (rev 186)
+++ trunk/NAMESPACE	2008-06-25 13:58:37 UTC (rev 187)
@@ -32,7 +32,8 @@
 	BIC,
 	fit,
 	npar,
-	freepars,
+	freepars,
+	nlin,
 	getdf,
 	nobs,
 	nresp,

Modified: trunk/R/EM.R
===================================================================
--- trunk/R/EM.R	2008-06-24 21:02:54 UTC (rev 186)
+++ trunk/R/EM.R	2008-06-25 13:58:37 UTC (rev 187)
@@ -81,7 +81,9 @@
 
 	# no constraints in EM
 	object at conMat <- matrix()
-
+	object at lin.lower <- numeric()
+	object at lin.upper <- numeric()
+	
 	object
 	
 }
@@ -170,6 +172,8 @@
 	
 	# no constraints in EM
 	object at conMat <- matrix()
+	object at lin.lower <- numeric()
+	object at lin.upper <- numeric()
 	
 	object
 }

Modified: trunk/R/allGenerics.R
===================================================================
--- trunk/R/allGenerics.R	2008-06-24 21:02:54 UTC (rev 186)
+++ trunk/R/allGenerics.R	2008-06-25 13:58:37 UTC (rev 187)
@@ -32,6 +32,8 @@
 
 setGeneric("freepars", function(object, ...) standardGeneric("freepars"))
 
+setGeneric("nlin", function(object, ...) standardGeneric("nlin"))
+
 setGeneric("logLik", function(object, ...) standardGeneric("logLik"))
 
 setGeneric("fit", function(object, ...) standardGeneric("fit"))

Modified: trunk/R/depmixfit-class.R
===================================================================
--- trunk/R/depmixfit-class.R	2008-06-24 21:02:54 UTC (rev 186)
+++ trunk/R/depmixfit-class.R	2008-06-25 13:58:37 UTC (rev 187)
@@ -10,6 +10,8 @@
 setClass("mix.fitted",
 	representation(message="character", # convergence information
 		conMat="matrix", # constraint matrix on the parameters for general linear constraints
+		lin.upper="numeric", # upper bounds for linear constraints
+		lin.lower="numeric", # lower bounds for linear constraints
 		posterior="data.frame" # posterior probabilities for the states
 	),
 	contains="mix"
@@ -60,6 +62,8 @@
 setClass("depmix.fitted",
 	representation(message="character", # convergence information
 		conMat="matrix", # constraint matrix on the parameters for general linear constraints
+		lin.upper="numeric", # upper bounds for linear constraints
+		lin.lower="numeric", # lower bounds for linear constraints
 		posterior="data.frame" # posterior probabilities for the states
 	),
 	contains="depmix"
Modified: trunk/R/depmixfit.R
===================================================================
--- trunk/R/depmixfit.R	2008-06-24 21:02:54 UTC (rev 186)
+++ trunk/R/depmixfit.R	2008-06-25 13:58:37 UTC (rev 187)
@@ -113,6 +113,8 @@
 			
 			object at conMat <- linconFull
 			object at message <- result$message
+			object at lin.upper <- lin.u
+			object at lin.lower <- lin.l
 			
 			# put the result back into the model
 			allpars[!fixed] <- result$par
Modified: trunk/R/freepars.R
===================================================================
--- trunk/R/freepars.R	2008-06-24 21:02:54 UTC (rev 186)
+++ trunk/R/freepars.R	2008-06-25 13:58:37 UTC (rev 187)
@@ -1,8 +1,7 @@
-# depends on nlin(object) and getpars(object)
+# depends on getpars(object)
 setMethod("freepars","mix",
 	function(object) {
 		free <- sum(!getpars(object,which="fixed"))
-# 		free <- free-nlin(object) # FIX ME!!!!
 		free
 	}
 )
@@ -11,7 +10,7 @@
 setMethod("freepars","depmix.fitted",
 	function(object) {
 		free <- sum(!getpars(object,which="fixed"))
- 		free <- free-nlin(object) # FIX ME!!!!
+ 		free <- free-nlin(object) 
 		free
 	}
 )
@@ -20,7 +19,22 @@
 setMethod("freepars","mix.fitted",
 	function(object) {
 		free <- sum(!getpars(object,which="fixed"))
- 		free <- free-nlin(object) # FIX ME!!!!
+		free <- free-nlin(object) 
 		free
 	}
-)
\ No newline at end of file
+)
+
+setMethod("nlin","mix.fitted",
+	function(object) {
+		nlin <- qr(object at conMat[which(object at lin.lower==object at lin.upper),,drop=FALSE])$rank
+		nlin
+	}
+)
+
+setMethod("nlin","depmix.fitted",
+	function(object) {
+		nlin <- qr(object at conMat[which(object at lin.lower==object at lin.upper),,drop=FALSE])$rank
+		nlin
+	}
+)
+