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

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

Author: ingmarvisser
Date: 2012-07-25 18:00:17 +0200 (Wed, 25 Jul 2012)
New Revision: 542

Modified:
   pkg/depmixS4/R/depmixfit-class.R
Log:
Added argument compact=TRUE to show method for fitted depmix objects to give shorter presentations for models without covariates.

Modified: pkg/depmixS4/R/depmixfit-class.R
===================================================================
--- pkg/depmixS4/R/depmixfit-class.R	2012-07-25 14:57:32 UTC (rev 541)
+++ pkg/depmixS4/R/depmixfit-class.R	2012-07-25 16:00:17 UTC (rev 542)
@@ -99,8 +99,11 @@
 	}
 )
 
+# copied from hmmr (and removed there)
+
 setMethod("summary","depmix.fitted",
-	function(object,which="all") {
+	function(object,which="all", compact=TRUE) {
+		ns <- object at nstates
 		ans=switch(which,
 			"all" = 1,
 			"response" = 2,
@@ -109,30 +112,73 @@
 			stop("Invalid 'which' argument in summary of fitted depmix model")
 		)
 		if(ans==1|ans==3) {
-			cat("Initial state probabilties model \n")
-			show(object at prior)
-			cat("\n")
+				# show the prior models
+				cat("Initial state probabilties model \n")
+				if(compact & object at prior@formula==~1) {
+						pr <- object at prior@parameters$coefficients
+						rownames(pr) <- ""
+						colnames(pr) <- paste("St",1:ns,sep="")
+						cat(pr,"\n")
+				} else show(object at prior)
 		}
 		if(ans==1|ans==4) {
-			for(i in 1:object at nstates) {
-				cat("Transition model for state (component)", i,"\n")
-				show(object at transition[[i]])
-				cat("\n")
-			}
-			cat("\n")
+				# show the transition models
+				if(compact & 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")
+				}
 		}
 		if(ans==1|ans==2) {
-			for(i in 1:object at nstates) {
-				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]])
+				# 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")
 				}
-				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) {
+						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)
 			}
 		}
 	}
 )
 
 
+