[Depmix-commits] r164 - trunk/R

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

Author: maarten
Date: 2008-06-13 18:05:45 +0200 (Fri, 13 Jun 2008)
New Revision: 164

Modified:
   trunk/R/responseGLMMULTINOM.R
   trunk/R/transInit.R
Log:
set transpose before setpars in fit MULTINOMresponse (as in fit transInit). But there is still a problem in setpars...

Modified: trunk/R/responseGLMMULTINOM.R
===================================================================
--- trunk/R/responseGLMMULTINOM.R	2008-06-13 15:37:20 UTC (rev 163)
+++ trunk/R/responseGLMMULTINOM.R	2008-06-13 16:05:45 UTC (rev 164)
@@ -3,6 +3,7 @@
 
 setMethod("fit","MULTINOMresponse",
 	function(object,w) {
+    if(missing(w)) w <- NULL
 		pars <- object at parameters
 		base <- object at family$base # delete me
 		y <- object at y
@@ -13,8 +14,12 @@
 		mask <- rbind(0,mask) # fix "bias" nodes to 0
 		Wts <- mask
 		Wts[-1,] <- t(pars$coefficients) # set starting weights
-		fit <- nnet.default(x,y,weights=w,size=0,entropy=TRUE,skip=TRUE,mask=mask,Wts=Wts,trace=FALSE)
-		pars$coefficients <- matrix(fit$wts,ncol=ncol(pars$coefficients),nrow=nrow(pars$coefficients)+1)[-1,]
+		if(!is.null(w)) {
+		  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,size=0,entropy=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
 	}
Modified: trunk/R/transInit.R
===================================================================
--- trunk/R/transInit.R	2008-06-13 15:37:20 UTC (rev 163)
+++ trunk/R/transInit.R	2008-06-13 16:05:45 UTC (rev 164)
@@ -82,82 +82,6 @@
 	function(object,w,ntimes) {
 		pars <- object at parameters
 		if(missing(w)) w <- NULL
-		oldfit <- function() {
-			tol <- 1e-5 # TODO: check global options
-			pars <- object at parameters
-			b <- pars$coefficients
-			base <- object at family$base
-			if(is.matrix(w)) nan <- which(is.na(rowSums(w))) else nan <- which(is.na(w))
-			#vgam(cbind(w[,-base],w[,base]) ~ ) # what is this?
-			y <- as.vector(t(object at family$linkinv(w[-c(nan,ntimes),-base],base=object at family$base)))
-			x <- object at x[-c(nan,ntimes),]			
-			if(!is.matrix(x)) x <- matrix(x,ncol=ncol(object at x))
-			nt <- nrow(x)			
-			Z <- matrix(ncol=length(b))
-			Z <- vector()
-			for(i in 1:nt) Z <- rbind(Z,t(bdiag(rep(list(x[i,]),ncol(w)-1))))			
-			mu <- object at family$linkinv(x%*%b,base=base)			
-			mt <- as.numeric(t(mu[,-base]))
-			Dl <- Sigmal <- Wl <- list()			
-			converge <- FALSE
-			while(!converge) {
-				b.old <- b
-				for(i in 1:nt) {
-					Dl[[i]] <- object at family$mu.eta(mu[i,-base])
-					Sigmal[[i]] <- object at family$variance(mu[i,-base])
-					Wl[[i]] <- Dl[[i]]%*%solve(Sigmal[[i]])%*%t(Dl[[i]]) # TODO: 
-				}
-				Sigma <- bdiag(Sigmal)
-				D <- bdiag(Dl)
-				W <- bdiag(Wl)
-				
-				b[,-base] <- as.numeric(b[,-base]) + solve(t(Z)%*%W%*%Z)%*%(t(Z)%*%D%*%solve(Sigma)%*%(y-mt))
-				if(abs(sum(b-b.old)) < tol) converge <- TRUE
-				mu <- object at family$linkinv(x%*%b,base=base)
-				mt <- as.numeric(t(mu[,-base]))
-			}
-			pars$coefficients <- t(b) # TODO: setpars gets matrix in wrong order!!! Fix this in setpars.
-			pars
-		}
-		
-		vglmfit <- function() {		
-			base <- object at family$base
-			w <- cbind(w[,-base],w[,base])
-			x <- slot(object,"x")
-			fam <- slot(object,"family")
-			fit <- vglm(w~x,fam)
-			pars$coefficients[,-base] <- t(slot(fit,coefficients))  # TODO: setpars gets matrix in wrong order!!! Fix this in setpars.
-			pars
-		}
-		
-		nnetfit <- function() {
-			pars <- object at parameters
-			base <- object at family$base # delete me
-			#y <- object at y[,-base]
-			y <- object at y
-			x <- object at x
-			if(is.matrix(y)) na <- unlist(apply(y,2,function(x) which(is.na(x)))) else na <- which(is.na(y))
-			if(is.matrix(x)) na <- c(na,unlist(apply(x,2,function(x) which(is.na(x))))) else na <- c(na,which(is.na(x)))
-			if(!is.null(w)) na <- c(na,which(is.na(w)))
-			y <- as.matrix(y)
-			x <- as.matrix(x)
-			na <- unique(na)
-			x <- x[-na,]
-			y <- y[-na,]
-			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
-			if(!is.null(w)) fit <- multinom(y~x-1,weights=w,trace=FALSE) else fit <- multinom(y~x-1,weights=w,trace=FALSE)
-			ids <- vector(,length=ncol(y))
-			ids[base] <- 1
-			ids[-base] <- 2:ncol(y)
-			pars$coefficients <- t(matrix(fit$wts,ncol=ncol(y))[-1,ids])
-			object <- setpars(object,unlist(pars))
-			#object
-			pars
-		}
-		
 		pars <- object at parameters
 		base <- object at family$base # delete me
 		#y <- object at y[,-base]