[Depmix-commits] r484 - pkg/depmixS4/R

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

Author: maarten
Date: 2011-06-28 18:07:04 +0200 (Tue, 28 Jun 2011)
New Revision: 484

Modified:
   pkg/depmixS4/R/responseGLM.R
   pkg/depmixS4/R/responseMVN.R
   pkg/depmixS4/R/setpars.R
Log:
- added a fix for models without covariates/intercepts. In responseGLM and responseMVN the function setpars now exits when length(value) == 0. In setpars.depmix, a check is added whether npar > 0. 

Modified: pkg/depmixS4/R/responseGLM.R
===================================================================
--- pkg/depmixS4/R/responseGLM.R	2011-06-27 09:40:42 UTC (rev 483)
+++ pkg/depmixS4/R/responseGLM.R	2011-06-28 16:07:04 UTC (rev 484)
@@ -164,6 +164,7 @@
 		if(length(values)!=npar) stop("length of 'values' must be",npar)
 		# determine whether parameters or fixed constraints are being set
 		nms <- names(object at parameters$coefficients)
+		if(length(values) == 0) return(object) # nothing to set; 
 		switch(which,
 			"pars"= {
 				if(object at family$family=="multinomial") {
@@ -233,4 +234,4 @@
 	function(object) {
 		object at family$linkinv(object at x%*%object at parameters$coefficients)
 	}
-)
\ No newline at end of file
+)
Modified: pkg/depmixS4/R/responseMVN.R
===================================================================
--- pkg/depmixS4/R/responseMVN.R	2011-06-27 09:40:42 UTC (rev 483)
+++ pkg/depmixS4/R/responseMVN.R	2011-06-28 16:07:04 UTC (rev 484)
@@ -182,6 +182,7 @@
 		if(length(values)!=npar) stop("length of 'values' must be",npar)
 		# determine whether parameters or fixed constraints are being set
 		nms <- names(object at parameters$coefficients)
+		if(length(values) == 0) return(object) # nothing to set;
 		switch(which,
 			"pars" = {
 				object at parameters$coefficients <- matrix(values[1:length(object at parameters$coefficients)],ncol(object at x))

Modified: pkg/depmixS4/R/setpars.R
===================================================================
--- pkg/depmixS4/R/setpars.R	2011-06-27 09:40:42 UTC (rev 483)
+++ pkg/depmixS4/R/setpars.R	2011-06-28 16:07:04 UTC (rev 484)
@@ -3,56 +3,62 @@
 	function(object,values,which="pars",...) {
 		if(!(length(values)==npar(object))) stop("Argument 'values' has incorrect length")
 		bp <- npar(object at prior)
-		switch(which,
-			"pars" = {
-				if(!all(getpars(object at prior,which=which) == values[1:bp])) {
-					object at prior=setpars(object at prior,values[1:bp],which=which)
-					# recompute init probabilities
-					object at init <- dens(object at prior)
-				}
-			},
-			"fixed" = {
-				object at prior <- setpars(object at prior,values[1:bp],which=which)
-			}
-		)
-		bp <- bp+1
-		values <- values[bp:npar(object)]
+		if(bp > 0) {
+		  switch(which,
+			  "pars" = {
+				  if(!all(getpars(object at prior,which=which) == values[1:bp])) {
+					  object at prior=setpars(object at prior,values[1:bp],which=which)
+					  # recompute init probabilities
+					  object at init <- dens(object at prior)
+				  }
+			  },
+			  "fixed" = {
+				  object at prior <- setpars(object at prior,values[1:bp],which=which)
+			  }
+		  )
+		  bp <- bp+1
+		  values <- values[bp:npar(object)]
+		}
 		if(class(object)=="depmix"|class(object)=="depmix.fitted") {
 			for(i in 1:object at nstates) {
 				bp <- npar(object at transition[[i]])
-				switch(which,
-					"pars"= {
-						if(!all(getpars(object at transition[[i]]) == values[1:bp])) {
-							object at transition[[i]] <- setpars(object at transition[[i]],values[1:bp])
-							# recompute transition densities if pars have changed
-							object at trDens[,,i] <- dens(object at transition[[i]])
-						}
-					},
-					"fixed" = {
-						object at transition[[i]] <- setpars(object at transition[[i]],values[1:bp],which="fixed")
-					}
-				)
-				bp <- bp+1
-				values <- values[bp:length(values)]
+				if(bp > 0) {
+				  switch(which,
+					  "pars"= {
+						  if(!all(getpars(object at transition[[i]]) == values[1:bp])) {
+							  object at transition[[i]] <- setpars(object at transition[[i]],values[1:bp])
+							  # recompute transition densities if pars have changed
+							  object at trDens[,,i] <- dens(object at transition[[i]])
+						  }
+					  },
+					  "fixed" = {
+						  object at transition[[i]] <- setpars(object at transition[[i]],values[1:bp],which="fixed")
+					  }
+				  )
+				  bp <- bp+1
+				  values <- values[bp:length(values)]
+				}
 			}
 		}
 		for(i in 1:object at nstates) {
 			for(j in 1:object at nresp) {
 				bp <- npar(object at response[[i]][[j]])
-				switch(which,
-					"pars" = {
-						if(!all(getpars(object at response[[i]][[j]]) == values[1:bp])) {
-							object at response[[i]][[j]] <- setpars(object at response[[i]][[j]],values[1:bp])
-							# recompute observation densities if pars have changed
-							object at dens[,j,i] <- dens(object at response[[i]][[j]])
-						}
-					},
-					"fixed" = {
-						object at response[[i]][[j]] <- setpars(object at response[[i]][[j]],values[1:bp],which="fixed")
-					}
-				)	
-				bp <- bp+1
-				values <- values[bp:length(values)]
+				if(bp > 0) {
+				  switch(which,
+					  "pars" = {
+						  if(!all(getpars(object at response[[i]][[j]]) == values[1:bp])) {
+							  object at response[[i]][[j]] <- setpars(object at response[[i]][[j]],values[1:bp])
+							  # recompute observation densities if pars have changed
+							  object at dens[,j,i] <- dens(object at response[[i]][[j]])
+						  }
+					  },
+					  "fixed" = {
+						  object at response[[i]][[j]] <- setpars(object at response[[i]][[j]],values[1:bp],which="fixed")
+					  }
+				  )	
+				  bp <- bp+1
+				  values <- values[bp:length(values)]
+				}
 			}
 		}			
 		return(object)