[Depmix-commits] r385 - trunk/R

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

Author: ingmarvisser
Date: 2010-03-05 15:06:55 +0100 (Fri, 05 Mar 2010)
New Revision: 385

Modified:
   trunk/R/allGenerics.R
   trunk/R/depmix-class.R
   trunk/R/makeResponseModels.R
   trunk/R/responseGLM.R
   trunk/R/transInit.R
Log:
Starting values for multinomial identity models now sum to unity.

Modified: trunk/R/allGenerics.R
===================================================================
--- trunk/R/allGenerics.R	2010-03-05 13:11:53 UTC (rev 384)
+++ trunk/R/allGenerics.R	2010-03-05 14:06:55 UTC (rev 385)
@@ -40,7 +40,7 @@
 
 setGeneric("nlin", function(object, ...) standardGeneric("nlin"))
 
-setGeneric("getModel", function(object, ...) standardGeneric("getModel"))
+# setGeneric("getModel", function(object, ...) standardGeneric("getModel"))
 
 # setGeneric("logLik", function(object, ...) standardGeneric("logLik"))
 

Modified: trunk/R/depmix-class.R
===================================================================
--- trunk/R/depmix-class.R	2010-03-05 13:11:53 UTC (rev 384)
+++ trunk/R/depmix-class.R	2010-03-05 14:06:55 UTC (rev 385)
@@ -131,14 +131,14 @@
 	}
 )
 
-setMethod("getModel",signature(object="mix"),
-	function(object,which="response",...) {
-		res <- switch(which,
-			"prior"=object at prior,
-			"response"=object at response)
-		res
-	}
-)
+# setMethod("getModel",signature(object="mix"),
+# 	function(object,which="response",...) {
+# 		res <- switch(which,
+# 			"prior"=object at prior,
+# 			"response"=object at response)
+# 		res
+# 	}
+# )
 
 # 
 # PRINT method
@@ -304,15 +304,15 @@
 	}
 )
 
-setMethod("getModel",signature(object="depmix"),
-	function(object,which="response",...) {
-		res <- switch(which,
-			"prior"=object at prior,
-			"response"=object at response,
-			"transition"=object at transition)
-		res
-	}
-)
+# setMethod("getModel",signature(object="depmix"),
+# 	function(object,which="response",...) {
+# 		res <- switch(which,
+# 			"prior"=object at prior,
+# 			"response"=object at response,
+# 			"transition"=object at transition)
+# 		res
+# 	}
+# )
 
 # 
 # SUMMARY method: to do

Modified: trunk/R/makeResponseModels.R
===================================================================
--- trunk/R/makeResponseModels.R	2010-03-05 13:11:53 UTC (rev 384)
+++ trunk/R/makeResponseModels.R	2010-03-05 14:06:55 UTC (rev 385)
@@ -7,23 +7,19 @@
 		
 	# univariate response data
 	if(class(resp)=="formula") {
-		nresp <- 1
-		for(i in 1:nstates) {
-			response[[i]] <- list()
-			response[[i]][[1]] <- GLMresponse(resp,data=data,family=family)
-			nresppars <- nresppars + npar(response[[i]][[1]])
-		}
+		resp <- list(resp)
+		family <- list(family)
 	}
 	
-	# multivariate response data
-	if(is.list(resp)) {
-		nresp <- length(resp)
-		for(i in 1:nstates) {
-			response[[i]] <- list()
-			for(j in 1:nresp) {
-				response[[i]][[j]] <- GLMresponse(resp[[j]],data=data,family=family[[j]])
-				nresppars <- nresppars + npar(response[[i]][[j]])
-			}
+	if(!(length(resp)==length(family))) stop("Length of 'response' list and 'family' list do not match")
+	
+	# make response model
+	nresp <- length(resp)
+	for(i in 1:nstates) {
+		response[[i]] <- list()
+		for(j in 1:nresp) {				
+			response[[i]][[j]] <- GLMresponse(resp[[j]],data=data,family=family[[j]])
+			nresppars <- nresppars + npar(response[[i]][[j]])
 		}
 	}
 	
@@ -33,7 +29,7 @@
 		for(i in 1:nstates) {
 			for(j in 1:nresp) {
 				bp <- npar(response[[i]][[j]])
-				response[[i]][[j]] <- setpars(response[[i]][[j]],val=values[1:bp],prob=prob)
+				response[[i]][[j]] <- GLMresponse(resp[[j]],data=data,family=family[[j]],pstart=values[1:bp],prob=prob)
 				bp <- bp+1
 				values <- values[bp:length(values)]
 			}

Modified: trunk/R/responseGLM.R
===================================================================
--- trunk/R/responseGLM.R	2010-03-05 13:11:53 UTC (rev 384)
+++ trunk/R/responseGLM.R	2010-03-05 14:06:55 UTC (rev 385)
@@ -77,8 +77,10 @@
 		if(!is.null(pstart)) {
 			if(length(pstart)!=npar) stop("length of 'pstart' must be",npar)
 			if(family$family=="multinomial") {
-				if(family$link=="identity") parameters$coefficients[1,] <- family$linkfun(pstart[1:ncol(parameters$coefficients)])
-				else {
+				if(family$link=="identity") {
+					parameters$coefficients[1,] <- pstart[1:ncol(parameters$coefficients)]/sum(pstart[1:ncol(parameters$coefficients)])
+					
+				} else {
 					if(prob) parameters$coefficients[1,] <- family$linkfun(pstart[1:ncol(parameters$coefficients)],base=family$base)
 					else parameters$coefficients[1,] <- pstart[1:ncol(parameters$coefficients)]
 				}
Modified: trunk/R/transInit.R
===================================================================
--- trunk/R/transInit.R	2010-03-05 13:11:53 UTC (rev 384)
+++ trunk/R/transInit.R	2010-03-05 14:06:55 UTC (rev 385)
@@ -47,8 +47,9 @@
 			if(family$family=="multinomial") {
 				if(family$link=="identity") {
 					parameters$coefficients[1,] <- pstart[1:ncol(parameters$coefficients)]
+					parameters$coefficients[1,] <- parameters$coefficients[1,]/sum(parameters$coefficients[1,])
 					pstart <- matrix(pstart,ncol(x),byrow=TRUE)
-					if(ncol(x)>1) parameters$coefficients[2:ncol(x),] <- pstart[2:ncol(x),]
+					if(ncol(x)>1) parameters$coefficients[2:ncol(x),] <- pstart[2:ncol(x),] # this cannot occur ...
 				} else {
 					if(prob) {
 						parameters$coefficients[1,] <- family$linkfun(pstart[1:ncol(parameters$coefficients)],base=family$base)
@@ -63,6 +64,7 @@
 				else parameters$coefficients <- family$linkfun(pstart[1:length(parameters$coefficients)],base=family$base)
 			}
 		}
+		# FIX this: do we need a switch here?
 		mod <- switch(family$family,
 			multinomial = new("transInit",formula=formula,family=family,parameters=parameters,fixed=fixed,x=x,y=y,npar=npar),
 			new("transInit",formula=formula,family=family,parameters=parameters,fixed=fixed,x=x,y=y,npar=npar)