[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