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

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

Author: maarten
Date: 2017-03-30 12:24:40 +0200 (Thu, 30 Mar 2017)
New Revision: 653

Modified:
   pkg/depmixS4/R/fb.R
   pkg/depmixS4/R/responseGLM.R
Log:
fixed problem with missing values in glm.fit

Modified: pkg/depmixS4/R/fb.R
===================================================================
--- pkg/depmixS4/R/fb.R	2016-02-12 08:12:29 UTC (rev 652)
+++ pkg/depmixS4/R/fb.R	2017-03-30 10:24:40 UTC (rev 653)
@@ -30,7 +30,8 @@
 	
 	if(na.allow) B <- replace(B,is.na(B) & !is.nan(B),1)
 
-	B <- apply(B,c(1,3),prod)
+    # 22/2/2017: avoid apply if not necessary
+	if(dim(B)[2]>1) B <- apply(B,c(1,3),prod) else dim(B) <- dim(B)[c(1,3)]
 	
 	if(is.null(ntimes)) ntimes <- nt
 	
@@ -40,11 +41,12 @@
 	
  	if(useC) {
 		
-		alpha <- matrix(0,ncol=ns,nrow=nt)
-		sca <- rep(0,nt)
+		# 22/2/2017: initialize as doubles
+		alpha <- matrix(0.0,ncol=ns,nrow=nt)
+		sca <- rep(0.0,nt)
 		
-		beta <- matrix(0,ncol=ns,nrow=nt)
-		xi <- array(0,dim=c(nt,ns,ns))
+		beta <- matrix(0.0,ncol=ns,nrow=nt)
+		xi <- array(0.0,dim=c(nt,ns,ns))
 		
 		res <- .C("forwardbackward",
 			hom=as.integer(homogeneous),
@@ -71,10 +73,11 @@
 				
 	} else {
 		
-		alpha <- matrix(ncol=ns,nrow=nt)
-		beta <- matrix(ncol=ns,nrow=nt)
-		sca <- vector(length=nt)
-		xi <- array(dim=c(nt,ns,ns))
+		# 22/2/2017: initialize as doubles
+		alpha <- matrix(0.0,ncol=ns,nrow=nt)
+		beta <- matrix(0.0,ncol=ns,nrow=nt)
+		sca <- vector("double",length=nt)
+		xi <- array(0.0,dim=c(nt,ns,ns))
 		
 		for(case in 1:lt) {
 			alpha[bt[case],] <- init[case,]*B[bt[case],] # initialize

Modified: pkg/depmixS4/R/responseGLM.R
===================================================================
--- pkg/depmixS4/R/responseGLM.R	2016-02-12 08:12:29 UTC (rev 652)
+++ pkg/depmixS4/R/responseGLM.R	2017-03-30 10:24:40 UTC (rev 653)
@@ -246,7 +246,16 @@
 		pars <- object at parameters
 		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)
+		# 22/2/2017: check for missing data and remove (necessary for Poission regression)
+		nas <- any(is.na(object at y))
+		if(sum(nas)>0) {
+		  x <- object at x[!is.na(object at y),,drop=FALSE]
+		  y <- object at y[!is.na(object at y),,drop=FALSE]
+		  w <- w[!is.na(object at y)]
+		  fit <- glm.fit(x=x,y=y,weights=w,family=object at family,start=start)
+		} else {
+		  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))
 		object