[Depmix-commits] r635 - pkg/depmixS4/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Aug 26 13:07:30 CEST 2014
Author: ingmarvisser
Date: 2014-08-26 13:07:30 +0200 (Tue, 26 Aug 2014)
New Revision: 635
Modified:
pkg/depmixS4/R/depmix-class.R
pkg/depmixS4/R/depmixfit.R
pkg/depmixS4/R/responseGLM.R
Log:
1) improved error message when optimization method is wrongly specified in fit function
2) fixed a bug in the summary method for fitted models (in some cases parameters of the prior model were printed in the transition matrix; thanks to Verena Schmittmann for catching this bug)
Modified: pkg/depmixS4/R/depmix-class.R
===================================================================
--- pkg/depmixS4/R/depmix-class.R 2014-05-22 11:12:11 UTC (rev 634)
+++ pkg/depmixS4/R/depmix-class.R 2014-08-26 11:07:30 UTC (rev 635)
@@ -354,113 +354,112 @@
# 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
- print(pr)
- cat("\n")
- } else show(object at prior)
+ function(object, which="all", compact=TRUE, digits=3) {
+ 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(round(pr,digits))
+ 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)
+ npprior <- length(getpars(object at prior))
+ trm <- matrix(pars[(npprior+1):(ns^2+npprior)],ns,ns,byr=T)
+ if(object at transition[[1]]@family$link == "mlogit") {
+ trm <- t(apply(trm,1,object at transition[[1]]@family$linkinv,base=object at transition[[1]]@family$base))
}
- 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)
- if(object at transition[[1]]@family$link == "mlogit") {
- trm <- t(apply(trm,1,object at transition[[1]]@family$linkinv,base=object at transition[[1]]@family$base))
- }
- 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")
- }
+ rownames(trm) <- paste("fromS",1:ns,sep="")
+ colnames(trm) <- paste("toS",1:ns,sep="")
+ print(round(trm,digits))
+ cat("\n")
+ trm
+ } else {
+ for(i in 1:ns) {
+ cat("Transition model for state (component)", i,"\n")
+ show(object at transition[[i]])
+ 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) {
- # FIXME: responses can have different families too!
- if("family" %in% slotNames(object at response[[1]][[j]])) cat("Resp",j, ":", object at response[[1]][[j]]@family$family, "\n")
- }
- pars <- list()
- np <- numeric(object at nresp)
- # get the parameter names
- allparnames <- list()
- parnames <- list() # for renaming empty names
- for(j in 1:object at nresp) {
- parnames[[j]] <- list()
- nms <- character()
- for(i in 1:ns) {
- tnms <- names(getpars(object at response[[i]][[j]]))
- if(is.null(tnms)) tnms=rep("",length=length(getpars(object at response[[i]][[j]])))
- if(any(tnms == "")) {
- tnms[tnms == ""] <- paste("anonym",1:sum(tnms == ""),sep="") # assume unnamed parameters are the same between states
- }
- parnames[[j]][[i]] <- tnms
- nms <- c(nms,tnms)
- }
- allparnames[[j]] <- unique(nms)
- }
-
-
- for(j in 1:object at nresp) {
- #np[j] <- npar(object at response[[1]][[j]]) # this will not always work!
- np[j] <- length(allparnames[[j]])
- pars[[j]] <- matrix(,nr=ns,nc=np[j])
- colnames(pars[[j]]) <- allparnames[[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
- pars[[j]][i,parnames[[j]][[i]]] <- tmp
- }
- nmsresp <- paste("Re",j,sep="")
- #nmstmp <- names(tmp)
- nmstmp <- allparnames[[j]]
- 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,na.print=".")
- }
+ 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) {
+ # FIXME: responses can have different families too!
+ if("family" %in% slotNames(object at response[[1]][[j]])) cat("Resp",j, ":", object at response[[1]][[j]]@family$family, "\n")
+ }
+ pars <- list()
+ np <- numeric(object at nresp)
+ # get the parameter names
+ allparnames <- list()
+ parnames <- list() # for renaming empty names
+ for(j in 1:object at nresp) {
+ parnames[[j]] <- list()
+ nms <- character()
+ for(i in 1:ns) {
+ tnms <- names(getpars(object at response[[i]][[j]]))
+ if(is.null(tnms)) tnms=rep("",length=length(getpars(object at response[[i]][[j]])))
+ if(any(tnms == "")) {
+ tnms[tnms == ""] <- paste("anonym",1:sum(tnms == ""),sep="") # assume unnamed parameters are the same between states
+ }
+ parnames[[j]][[i]] <- tnms
+ nms <- c(nms,tnms)
+ }
+ allparnames[[j]] <- unique(nms)
+ }
+ for(j in 1:object at nresp) {
+ #np[j] <- npar(object at response[[1]][[j]]) # this will not always work!
+ np[j] <- length(allparnames[[j]])
+ pars[[j]] <- matrix(,nr=ns,nc=np[j])
+ colnames(pars[[j]]) <- allparnames[[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
+ pars[[j]][i,parnames[[j]][[i]]] <- tmp
+ }
+ nmsresp <- paste("Re",j,sep="")
+ #nmstmp <- names(tmp)
+ nmstmp <- allparnames[[j]]
+ 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(round(allpars,digits),na.print=".")
}
-)
+ }
+})
Modified: pkg/depmixS4/R/depmixfit.R
===================================================================
--- pkg/depmixS4/R/depmixfit.R 2014-05-22 11:12:11 UTC (rev 634)
+++ pkg/depmixS4/R/depmixfit.R 2014-08-26 11:07:30 UTC (rev 635)
@@ -33,12 +33,12 @@
}
}
+ if(!(method %in% c("EM","donlp","rsolnp"))) stop("'method' argument invalid; should be one of 'EM', 'rsolnp', 'donlp'.")
+
if(method=="EM") {
object <- em(object,maxit=emcontrol$maxit,tol=emcontrol$tol,crit=emcontrol$crit,random.start=emcontrol$random.start,classification=emcontrol$classification,verbose=verbose,...)
}
- if(!(method %in% c("EM","donlp","rsolnp"))) stop("'method' argument invalid; should be one of 'EM', 'rsolnp', 'donlp'.")
-
if(method=="donlp"||method=="rsolnp") {
# check feasibility of starting values
@@ -84,20 +84,20 @@
# incorporate general linear constraints, if any
if(cr) {
- if(ncol(conrows)!=npar(object)) stop("'conrows' does not have the right dimensions")
- lincon <- rbind(lincon,conrows)
- if(is.null(conrows.upper)) {
- lin.u <- c(lin.u,rep(0,nrow(conrows)))
- } else {
- if(length(conrows.upper)!=nrow(conrows)) stop("'conrows.upper does not have correct length")
- lin.u <- c(lin.u,conrows.upper)
- }
- if(is.null(conrows.lower)) {
- lin.l <- c(lin.l,rep(0,nrow(conrows)))
- } else {
- if(length(conrows.lower)!=nrow(conrows)) stop("'conrows.lower does not have correct length")
- lin.l <- c(lin.l,conrows.lower)
- }
+ if(ncol(conrows)!=npar(object)) stop("'conrows' does not have the right dimensions")
+ lincon <- rbind(lincon,conrows)
+ if(is.null(conrows.upper)) {
+ lin.u <- c(lin.u,rep(0,nrow(conrows)))
+ } else {
+ if(length(conrows.upper)!=nrow(conrows)) stop("'conrows.upper does not have correct length")
+ lin.u <- c(lin.u,conrows.upper)
+ }
+ if(is.null(conrows.lower)) {
+ lin.l <- c(lin.l,rep(0,nrow(conrows)))
+ } else {
+ if(length(conrows.lower)!=nrow(conrows)) stop("'conrows.lower does not have correct length")
+ lin.l <- c(lin.l,conrows.lower)
+ }
}
# select only those columns of the constraint matrix that correspond to non-fixed parameters
Modified: pkg/depmixS4/R/responseGLM.R
===================================================================
--- pkg/depmixS4/R/responseGLM.R 2014-05-22 11:12:11 UTC (rev 634)
+++ pkg/depmixS4/R/responseGLM.R 2014-08-26 11:07:30 UTC (rev 635)
@@ -244,8 +244,8 @@
function(object,w) {
if(missing(w)) w <- NULL
pars <- object at parameters
- start <- pars$coefficients
- start[is.na(start)] <- 0
+ start <- pars$coefficients
+ start[is.na(start)] <- 0
fit <- glm.fit(x=object at x,y=object at y,weights=w,family=object at family,start=start)
pars$coefficients <- fit$coefficients
object <- setpars(object,unlist(pars))
More information about the depmix-commits
mailing list