[Depmix-commits] r221 - in trunk: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Aug 11 11:21:28 CEST 2008
Author: ingmarvisser
Date: 2008-08-11 11:21:28 +0200 (Mon, 11 Aug 2008)
New Revision: 221
Modified:
trunk/NEWS
trunk/R/responseGLM.R
trunk/R/responseGLMMULTINOM.R
trunk/R/transInit.R
Log:
Fixed a bug in show method for GLMresponse models
Modified: trunk/NEWS
===================================================================
--- trunk/NEWS 2008-08-05 18:53:28 UTC (rev 220)
+++ trunk/NEWS 2008-08-11 09:21:28 UTC (rev 221)
@@ -1,5 +1,10 @@
+Changes in depmixS4 version 0.2-1
+ o Fixed a bug in the Viterbi algorithm used to compute posterior states
+
+ o
+
Changes in depmixS4 version 0.2-0
o restructured R and Rd (help) files; added depmixS4 help with a short
@@ -27,9 +32,7 @@
o minor changes to make depmixS4 compatible with R 2.7.1
- o
-
Changes in depmixS4 version 0.1-1
o adjusted for R 2.7.0
Modified: trunk/R/responseGLM.R
===================================================================
--- trunk/R/responseGLM.R 2008-08-05 18:53:28 UTC (rev 220)
+++ trunk/R/responseGLM.R 2008-08-11 09:21:28 UTC (rev 221)
@@ -108,11 +108,18 @@
if(object at family$family=="multinomial") {
# also print probabilities at covariate values of zero
cat("Probalities at zero values of the covariates.\n")
- if(!(is.null(dim(object at parameters$coefficients)))&dim(object at parameters$coefficients)[1]>1) {
- cat(object at family$linkinv(object at parameters$coefficients[1,],base=object at family$base),"\n")
+ if(!(is.null(dim(object at parameters$coefficients)))) {
+ if(dim(object at parameters$coefficients)[1]>1) {
+ cat(object at family$linkinv(object at parameters$coefficients[1,],base=object at family$base),"\n")
+ } else {
+ cat(object at family$linkinv(object at parameters$coefficients,base=object at family$base),"\n")
+ }
} else {
if(object at family$link=="identity") cat(object at family$linkinv(object at parameters$coefficients),"\n")
- else cat(object at family$linkinv(object at parameters$coefficients,base=object at family$base),"\n")
+ else {
+ cat(object at family$linkinv(object at parameters$coefficients,base=object at family$base),"\n")
+ }
+
}
}
if(object at family$family=="binomial") {
@@ -141,7 +148,7 @@
# values <- matrix(values,,ncol(object at x),byrow=TRUE)
# if(ncol(object at x)>1) object at parameters$coefficients[2:ncol(object at x),] <- values[2:ncol(object at x),]
} else {
- object at parameters$coefficients <- values[1:length(object at parameters$coefficients)]
+ object at parameters$coefficients <- values[1:length(object at parameters$coefficients)] # matrix(values,ncol(object at x),byrow=TRUE) # this needs fixing!!!!
}
if(length(unlist(object at parameters))>length(object at parameters$coefficients)) {
if(object at family$family=="gaussian") object at parameters$sd <- as.numeric(values[(length(object at parameters$coefficients)+1)])
Modified: trunk/R/responseGLMMULTINOM.R
===================================================================
--- trunk/R/responseGLMMULTINOM.R 2008-08-05 18:53:28 UTC (rev 220)
+++ trunk/R/responseGLMMULTINOM.R 2008-08-11 09:21:28 UTC (rev 221)
@@ -16,16 +16,16 @@
Wts[-1,] <- t(pars$coefficients) # set starting weights
if(!is.null(w)) {
if(NCOL(y) < 3) {
- fit <- nnet.default(x,y,weights=w,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
- } else {
- fit <- nnet.default(x,y,weights=w,size=0,softmax=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
- }
+ fit <- nnet.default(x,y,weights=w,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
+ } else {
+ fit <- nnet.default(x,y,weights=w,size=0,softmax=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
+ }
} else {
- if(NCOL(y) < 3) {
- fit <- nnet.default(x,y,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
- } else {
- fit <- nnet.default(x,y,size=0,softmax=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
- }
+ if(NCOL(y) < 3) {
+ fit <- nnet.default(x,y,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
+ } else {
+ fit <- nnet.default(x,y,size=0,softmax=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
+ }
}
pars$coefficients <- t(matrix(fit$wts,ncol=ncol(pars$coefficients),nrow=nrow(pars$coefficients)+1)[-1,])
object <- setpars(object,unlist(pars))
@@ -56,19 +56,19 @@
)
setMethod("simulate",signature(object="MULTINOMresponse"),
- function(object,nsim=1,seed=NULL,times) {
- if(!is.null(seed)) set.seed(seed)
- if(missing(times)) {
- # draw all times in one go
- pr <- predict(object)
- } else {
- pr <- predict(object)[times,]
- if(length(times)==1) pr <- matrix(pr,ncol=length(pr))
- }
- nt <- nrow(pr)
- sims <- array(apply(pr,1,rmultinom,n=nsim,size=1),dim=c(ncol(pr),nsim,nt))
- sims <- matrix(aperm(sims,c(3,2,1)),nrow=nsim*nt,ncol=ncol(pr))
- #response <- t(apply(sims,c(2,3), function(x) which(x==1)))
- return(sims)
- }
+ function(object,nsim=1,seed=NULL,times) {
+ if(!is.null(seed)) set.seed(seed)
+ if(missing(times)) {
+ # draw all times in one go
+ pr <- predict(object)
+ } else {
+ pr <- predict(object)[times,]
+ if(length(times)==1) pr <- matrix(pr,ncol=length(pr))
+ }
+ nt <- nrow(pr)
+ sims <- array(apply(pr,1,rmultinom,n=nsim,size=1),dim=c(ncol(pr),nsim,nt))
+ sims <- matrix(aperm(sims,c(3,2,1)),nrow=nsim*nt,ncol=ncol(pr))
+ #response <- t(apply(sims,c(2,3), function(x) which(x==1)))
+ return(sims)
+ }
)
Modified: trunk/R/transInit.R
===================================================================
--- trunk/R/transInit.R 2008-08-05 18:53:28 UTC (rev 220)
+++ trunk/R/transInit.R 2008-08-11 09:21:28 UTC (rev 221)
@@ -19,7 +19,7 @@
mf[[1]] <- as.name("model.frame")
mf <- eval(mf, parent.frame())
x <- model.matrix(attr(mf, "terms"),mf)
- y <- matrix(1,ncol=1) # y is not needed in the transition and init models
+ y <- matrix(1,ncol=1) # y is not needed in the transition and init models
parameters <- list()
if(is.null(nstates)) stop("'nstates' must be provided in call to trinModel")
if(family$family=="multinomial") {
@@ -100,7 +100,6 @@
#y <- round(y) # delete me
if(!is.null(w)) w <- w[-na]
}
-
mask <- matrix(1,nrow=nrow(pars$coefficients),ncol=ncol(pars$coefficients))
mask[,base] <- 0 # fix base category coefficients to 0
mask <- rbind(0,mask) # fix "bias" nodes to 0
@@ -109,18 +108,18 @@
Wts[Wts == Inf] <- .Machine$double.max.exp # Fix this!!!!
Wts[Wts == -Inf] <- .Machine$double.min.exp # Fix this!!!!!
if(!is.null(w)) {
- if(NCOL(y) < 3) {
- fit <- nnet.default(x,y,weights=w,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
- } else {
- fit <- nnet.default(x,y,weights=w,size=0,softmax=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
- }
- } else {
- if(NCOL(y) < 3) {
- fit <- nnet.default(x,y,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
- } else {
- fit <- nnet.default(x,y,size=0,softmax=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
- }
- }
+ if(NCOL(y) < 3) {
+ fit <- nnet.default(x,y,weights=w,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
+ } else {
+ fit <- nnet.default(x,y,weights=w,size=0,softmax=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
+ }
+ } else {
+ if(NCOL(y) < 3) {
+ fit <- nnet.default(x,y,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
+ } else {
+ fit <- nnet.default(x,y,size=0,softmax=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
+ }
+ }
pars$coefficients <- t(matrix(fit$wts,ncol=ncol(pars$coefficients),nrow=nrow(pars$coefficients)+1)[-1,])
object <- setpars(object,unlist(pars))
object
@@ -128,26 +127,26 @@
)
setMethod("simulate",signature(object="transInit"),
- function(object,nsim=1,seed=NULL,times,is.prior=FALSE,...) {
- if(!is.null(seed)) set.seed(seed)
- if(is.prior) {
- pr <- dens(object)
- sims <- array(apply(pr,1,rmultinom,n=nsim,size=1),dim=c(ncol(pr),nsim,nrow(pr)))
- states <- t(apply(sims,c(2,3), function(x) which(x==1)))
- return(states)
- } else {
- if(missing(times)) {
- # this is likely to be a stationary model...
- pr <- predict(object)
- } else {
- pr <- predict(object)[times,]
- if(length(times)==1) pr <- matrix(pr,ncol=length(pr))
- }
- nt <- nrow(pr)
- sims <- array(apply(pr,1,rmultinom,n=nsim,size=1),dim=c(ncol(pr),nsim,nt))
- states <- t(apply(sims,c(2,3), function(x) which(x==1)))
- # states <- apply(apply(pr,2,rmultinom rmultinom(nt*nsim,size=1,prob=pr),2,function(x) which(x==1))
- return(states)
- }
- }
+ function(object,nsim=1,seed=NULL,times,is.prior=FALSE,...) {
+ if(!is.null(seed)) set.seed(seed)
+ if(is.prior) {
+ pr <- dens(object)
+ sims <- array(apply(pr,1,rmultinom,n=nsim,size=1),dim=c(ncol(pr),nsim,nrow(pr)))
+ states <- t(apply(sims,c(2,3), function(x) which(x==1)))
+ return(states)
+ } else {
+ if(missing(times)) {
+ # this is likely to be a stationary model...
+ pr <- predict(object)
+ } else {
+ pr <- predict(object)[times,]
+ if(length(times)==1) pr <- matrix(pr,ncol=length(pr))
+ }
+ nt <- nrow(pr)
+ sims <- array(apply(pr,1,rmultinom,n=nsim,size=1),dim=c(ncol(pr),nsim,nt))
+ states <- t(apply(sims,c(2,3), function(x) which(x==1)))
+ # states <- apply(apply(pr,2,rmultinom rmultinom(nt*nsim,size=1,prob=pr),2,function(x) which(x==1))
+ return(states)
+ }
+ }
)
\ No newline at end of file
More information about the depmix-commits
mailing list