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

noreply at r-forge.r-project.org noreply at r-forge.r-project.org
Mon Jul 30 16:38:18 CEST 2012


Author: ingmarvisser
Date: 2012-07-30 16:38:17 +0200 (Mon, 30 Jul 2012)
New Revision: 553

Modified:
   pkg/depmixS4/R/depmix-class.R
   pkg/depmixS4/R/responseGLM.R
   pkg/depmixS4/R/transInit.R
Log:
final (?) changes regarding parameter names, show and summary methods; output is now much more readable

Modified: pkg/depmixS4/R/depmix-class.R
===================================================================
--- pkg/depmixS4/R/depmix-class.R	2012-07-30 12:33:44 UTC (rev 552)
+++ pkg/depmixS4/R/depmix-class.R	2012-07-30 14:38:17 UTC (rev 553)
@@ -130,15 +130,6 @@
 	}
 )
 
-# setMethod("getModel",signature(object="mix"),
-# 	function(object,which="response",...) {
-# 		res <- switch(which,
-# 			"prior"=object at prior,
-# 			"response"=object at response)
-# 		res
-# 	}
-# )
-
 # 
 # PRINT method
 # 
@@ -167,8 +158,6 @@
 						cat("Mixture probabilities model \n")
 						if(object at prior@formula==~1) {
 								pr <- object at prior@parameters$coefficients
-								rownames(pr) <- ""
-								colnames(pr) <- paste("St",1:ns,sep="")
 								print(pr)
 						} else show(object at prior)
 						cat("\n")
@@ -354,16 +343,6 @@
 	}
 )
 
-# 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
 # 
@@ -371,83 +350,86 @@
 # copied from hmmr (and removed there)
 
 setMethod("summary","depmix",
-	function(object,which="all", compact=TRUE) {
-		ns <- object at nstates
-		ans=switch(which,
-			"all" = 1,
-			"response" = 2,
-			"prior" = 3,
-			"transition" = 4,
-			stop("Invalid 'which' argument in summary of fitted depmix model")
-		)
-		if(ans==1|ans==3) {
-				# show the prior models
-				cat("Initial state probabilties model \n")
-				if(object at prior@formula==~1) {
-						pr <- object at prior@parameters$coefficients
-						rownames(pr) <- ""
-						colnames(pr) <- paste("St",1:ns,sep="")
-						print(pr)
-						cat("\n")
-				} else show(object at prior)
-		}
-		if(ans==1|ans==4) {
-				# show the transition models
-				if(object at transition[[1]]@formula==~1) {
-						cat("\nTransition matrix \n")
-						pars <- getpars(object)
-						trm <- matrix(pars[(ns+1):(ns^2+ns)],ns,ns,byr=T)
-						rownames(trm) <- paste("fromS",1:ns,sep="")
-						colnames(trm) <- paste("toS",1:ns,sep="")
-						print(trm)
-						cat("\n")
-				} else {
-						for(i in 1:ns) {
-								cat("Transition model for state (component)", i,"\n")
-								show(object at transition[[i]])
+		function(object,which="all", compact=TRUE) {
+				ns <- object at nstates
+				ans=switch(which,
+						"all" = 1,
+						"response" = 2,
+						"prior" = 3,
+						"transition" = 4,
+						stop("Invalid 'which' argument in summary of fitted depmix model")
+				)
+				if(ans==1|ans==3) {
+						# show the prior models
+						cat("Initial state probabilties model \n")
+						if(object at prior@formula==~1) {
+								pr <- object at prior@parameters$coefficients
+								print(pr)
 								cat("\n")
+						} else show(object at prior)
+				}
+				if(ans==1|ans==4) {
+						# show the transition models
+						if(object at transition[[1]]@formula==~1) {
+								cat("\nTransition matrix \n")
+								pars <- getpars(object)
+								trm <- matrix(pars[(ns+1):(ns^2+ns)],ns,ns,byr=T)
+								rownames(trm) <- paste("fromS",1:ns,sep="")
+								colnames(trm) <- paste("toS",1:ns,sep="")
+								print(trm)
+								cat("\n")
+						} else {
+								for(i in 1:ns) {
+										cat("Transition model for state (component)", i,"\n")
+										show(object at transition[[i]])
+										cat("\n")
+								}
+								cat("\n")
 						}
-						cat("\n")
 				}
-		}
-		if(ans==1|ans==2) {
-				# show the response models
-			if(!compact) {
-				for(i in 1:ns) {
-					cat("Response model(s) for state", i,"\n\n")
-					for(j in 1:object at nresp) {
-						cat("Response model for response",j,"\n")
-						show(object at response[[i]][[j]])
-						cat("\n")
-					}
-					cat("\n")
+				if(ans==1|ans==2) {
+						# show the response models
+						if(!compact) {
+								for(i in 1:ns) {
+										cat("Response model(s) for state", i,"\n\n")
+										for(j in 1:object at nresp) {
+												cat("Response model for response",j,"\n")
+												show(object at response[[i]][[j]])
+												cat("\n")
+										}
+										cat("\n")
+								}
+						} else {
+								cat("Response parameters \n")
+								for(j in 1:object at nresp) {
+										cat("Resp",j, ":", object at response[[1]][[j]]@family$family, "\n")
+								}
+								pars <- list()
+								np <- numeric(object at nresp)
+								for(j in 1:object at nresp) {
+										np[j] <- npar(object at response[[1]][[j]])
+										pars[[j]] <- matrix(,nr=ns,nc=np[j])
+								}
+								allpars <- matrix(,nr=ns,nc=0)
+								nms <- c()
+								for(j in 1:object at nresp) {
+										for(i in 1:ns) {
+												tmp <- getpars(object at response[[i]][[j]])
+												pars[[j]][i,] <- tmp
+										}
+										nmsresp <- paste("Re",j,sep="")
+										nmstmp <- names(tmp)
+										if(is.null(nmstmp)) nmstmp <- 1:length(tmp)
+										nms <- c(nms,paste(nmsresp,nmstmp,sep="."))
+										allpars <- cbind(allpars,pars[[j]])					
+								}
+								rownames(allpars) <- paste("St",1:ns,sep="")
+								colnames(allpars) <- nms
+								print(allpars)
+						}
 				}
-			} else {
-				cat("Response parameters \n")
-				for(j in 1:object at nresp) {
-						cat("Resp",j, ":", object at response[[1]][[j]]@family$family, "\n")
-				}
-				pars <- list()
-				np <- numeric(object at nresp)
-				for(j in 1:object at nresp) {
-					np[j] <- npar(object at response[[1]][[j]])
-					pars[[j]] <- matrix(,nr=ns,nc=np[j])
-				}
-				allpars <- matrix(,nr=ns,nc=0)
-				nms <- c()
-				for(j in 1:object at nresp) {
-					for(i in 1:ns) {
-						pars[[j]][i,]=getpars(object at response[[i]][[j]])
-				}
-				nms <- c(nms,paste("Resp",j,1:np[j],sep="."))
-					allpars <- cbind(allpars,pars[[j]])					
-				}
-				rownames(allpars) <- paste("St",1:ns,sep="")
-				colnames(allpars) <- nms
-				print(allpars)
-			}
 		}
-	}
 )
 
 
+

Modified: pkg/depmixS4/R/responseGLM.R
===================================================================
--- pkg/depmixS4/R/responseGLM.R	2012-07-30 12:33:44 UTC (rev 552)
+++ pkg/depmixS4/R/responseGLM.R	2012-07-30 14:38:17 UTC (rev 553)
@@ -83,6 +83,7 @@
 			  if(is.null(namesy)) namesy <- 1:ncol(y)
 			  colnames(parameters$coefficients) <- namesy
 				rownames(parameters$coefficients) <- attr(x,"dimnames")[[2]]
+# 				if(ncol(x)==1) names(parameters$coefficients) <- 1:ncol(y)
 			}
 			if(family$link=="identity") {
 				if(ncol(x)>1) stop("covariates not allowed in multinomial model with identity link")
@@ -204,7 +205,6 @@
 	}
 )
 
-
 setMethod("getpars","GLMresponse",
 		function(object,which="pars",...) {
 				switch(which,
@@ -215,7 +215,12 @@
 										parameters <- c(t(object at parameters$coefficients)) # Why transpose?
 								} else {
 										parameters <- object at parameters$coefficients
-										if(object at family$family=="gaussian") parameters <- c(parameters,object at parameters$sd)
+										if(object at family$family=="gaussian") {
+												nms <- names(parameters)
+												parameters <- c(parameters,object at parameters$sd)
+												names(parameters) <- c(nms,"sd")
+										}
+										
 								}
 								pars <- parameters
 						},

Modified: pkg/depmixS4/R/transInit.R
===================================================================
--- pkg/depmixS4/R/transInit.R	2012-07-30 12:33:44 UTC (rev 552)
+++ pkg/depmixS4/R/transInit.R	2012-07-30 14:38:17 UTC (rev 553)
@@ -29,9 +29,11 @@
 		if(is.null(nstates)) stop("'nstates' must be provided in call to transInit model")
 		if(family$family=="multinomial") {
 			if(family$link=="identity") {
-				parameters$coefficients <- t(apply(matrix(1,ncol=nstates,nrow=ncol(x)),1,function(x) x/sum(x)))
+					if(ncol(x)>1) stop("covariates not allowed in multinomial model with identity link")
+					parameters$coefficients <- rep(1/nstates,nstates)
+					names(parameters$coefficients) <- paste("pr",1:nstates,sep="")
 				if(is.null(fixed)) {
-					fixed <- matrix(0,nrow=nrow(parameters$coefficients),ncol=ncol(parameters$coefficients))
+					fixed <- matrix(0,nrow=1,ncol=nstates)
 					fixed <- rep(0,nstates) # this needs to be fixed at some point using contraints
 					fixed <- c(as.logical(fixed))
 				}
@@ -48,7 +50,9 @@
 					fixed <- parameters$coefficients
 					fixed[,family$base] <- 1 
 					fixed <- c(as.logical(t(fixed)))
-				}
+			  }
+				colnames(parameters$coefficients) <- paste("St",1:nstates,sep="")
+				rownames(parameters$coefficients) <- attr(x,"dimnames")[[2]]
 			}
 		}
 		npar <- length(unlist(parameters))
@@ -57,10 +61,8 @@
 			if(length(pstart)!=npar) stop("length of 'pstart' must be ",npar)
 			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),] # this cannot occur ...
+					parameters$coefficients[1:nstates] <- pstart[1:nstates]
+					parameters$coefficients <- parameters$coefficients/sum(parameters$coefficients)
 				} else {
 					if(prob) {
 						parameters$coefficients[1,] <- family$linkfun(pstart[1:ncol(parameters$coefficients)],base=family$base)



More information about the depmix-commits mailing list