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

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

Author: ingmarvisser
Date: 2010-04-23 17:20:17 +0200 (Fri, 23 Apr 2010)
New Revision: 413

Modified:
   pkg/depmixS4/R/responseGLMMULTINOM.R
Log:
Fixed a bug in multinomial models with n>1

Modified: pkg/depmixS4/R/responseGLMMULTINOM.R
===================================================================
--- pkg/depmixS4/R/responseGLMMULTINOM.R	2010-03-10 21:25:56 UTC (rev 412)
+++ pkg/depmixS4/R/responseGLMMULTINOM.R	2010-04-23 15:20:17 UTC (rev 413)
@@ -46,14 +46,35 @@
 
 setMethod("logDens","MULTINOMresponse",
 	function(object) {
-		log(rowSums(object at y*predict(object)))
+		if(all(rowSums(object at y)==1)) {
+			return(log(rowSums(object at y*predict(object))))
+		} else {
+			nr <- nrow(object at y)
+			res <- matrix(nr=nr)
+			pr <- predict(object)
+			for(i in 1:nrow(object at y)) {
+				res[i,1] <- dmultinom(object at y[i,],pr=pr[i,])
+			}
+			return(log(res))
+		}
 	}
 )
 
 setMethod("dens","MULTINOMresponse",
 	function(object,log=FALSE) {
-		if(log) log(rowSums(object at y*predict(object)))
-		else rowSums(object at y*predict(object))
+		if(all(rowSums(object at y)==1)) {
+			if(log) return(log(rowSums(object at y*predict(object))))
+			else return(rowSums(object at y*predict(object)))
+		} else {
+			nr <- nrow(object at y)
+			res <- matrix(nr=nr)
+			pr <- predict(object)
+			for(i in 1:nrow(object at y)) {
+				res[i,1] <- dmultinom(object at y[i,],pr=pr[i,])
+			}
+			if(log) return(log(res)) 
+			else return(res)
+		}
 	}
 )