[Depmix-commits] r210 - pkg/R pkg/man trunk/R trunk/man

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

Author: maarten
Date: 2008-07-01 16:08:44 +0200 (Tue, 01 Jul 2008)
New Revision: 210

Modified:
   pkg/R/getpars.R
   pkg/R/responseGLM.R
   pkg/R/responseMVN.R
   pkg/man/depmix-internal.Rd
   trunk/R/getpars.R
   trunk/R/responseGLM.R
   trunk/R/responseMVN.R
   trunk/man/depmix-internal.Rd
Log:
setpars no longer renames elements in parameter list
splitted getpars(mix) into getpars(mix) and getpars(depmix)

Modified: pkg/R/getpars.R
===================================================================
--- pkg/R/getpars.R	2008-07-01 12:33:16 UTC (rev 209)
+++ pkg/R/getpars.R	2008-07-01 14:08:44 UTC (rev 210)
@@ -1,16 +1,26 @@
 setMethod("getpars","mix",
 	function(object,which="pars",...) {
 		parameters <- getpars(object at prior,which=which)
-		if(class(object)=="depmix"|class(object)=="depmix.fitted") {
-			for(i in 1:object at nstates) {
-				parameters <- c(parameters,getpars(object at transition[[i]],which=which))
+		for(i in 1:object at nstates) {
+			for(j in 1:object at nresp) {
+				parameters <- c(parameters,getpars(object at response[[i]][[j]],which=which))
 			}
-		}	
+		}
+		return(parameters)
+	}
+)
+
+setMethod("getpars","depmix",
+	function(object,which="pars",...) {
+		parameters <- getpars(object at prior,which=which)
 		for(i in 1:object at nstates) {
+			parameters <- c(parameters,getpars(object at transition[[i]],which=which))
+		}
+		for(i in 1:object at nstates) {
 			for(j in 1:object at nresp) {
 				parameters <- c(parameters,getpars(object at response[[i]][[j]],which=which))
 			}
 		}
 		return(parameters)
 	}
-)
+)
\ No newline at end of file

Modified: pkg/R/responseGLM.R
===================================================================
--- pkg/R/responseGLM.R	2008-07-01 12:33:16 UTC (rev 209)
+++ pkg/R/responseGLM.R	2008-07-01 14:08:44 UTC (rev 210)
@@ -130,6 +130,7 @@
 		npar <- npar(object)
 		if(length(values)!=npar) stop("length of 'values' must be",npar)
 		# determine whether parameters or fixed constraints are being set
+		nms <- names(object at parameters$coefficients)
 		switch(which,
 			"pars"= {
 				if(object at family$family=="multinomial") {
@@ -145,13 +146,14 @@
 					object at parameters$coefficients <- values[1:length(object at parameters$coefficients)]
 				}
 				if(length(unlist(object at parameters))>length(object at parameters$coefficients)) {
-					if(object at family$family=="gaussian") object at parameters$sd <- values[(length(object at parameters$coefficients)+1)]
+					if(object at family$family=="gaussian") object at parameters$sd <- as.numeric(values[(length(object at parameters$coefficients)+1)])
 				}
 			},
 			"fixed" = {
 				object at fixed <- as.logical(values)
 			}
 		)
+		names(object at parameters$coefficients) <- nms
 		return(object)
 	}
 )
Modified: pkg/R/responseMVN.R
===================================================================
--- pkg/R/responseMVN.R	2008-07-01 12:33:16 UTC (rev 209)
+++ pkg/R/responseMVN.R	2008-07-01 14:08:44 UTC (rev 210)
@@ -132,4 +132,40 @@
 	}
 )
 
-#TODO: setpars function
+setMethod("setpars","MVNresponse",
+	function(object, values, which="pars", prob=FALSE, ...) {
+		npar <- npar(object)
+		if(length(values)!=npar) stop("length of 'values' must be",npar)
+		# determine whether parameters or fixed constraints are being set
+		nms <- names(object at parameters$coefficients)
+		switch(which,
+			"pars" = {
+				object at parameters$coefficients <- matrix(values[1:length(object at parameters$coefficients)],ncol(object at x))
+			  if(length(unlist(object at parameters))>length(object at parameters$coefficients)) {
+          st <- length(object at parameters$coefficients)+1
+          object at parameters$Sigma <- matrix(as.numeric(values[st:(st+length(object at parameters$Sigma))]),ncol=ncol(object at parameters$Sigma),nrow=nrow(object at parameters$Sigma))
+			  }
+			},
+			"fixed" = {
+				object at fixed <- as.logical(values)
+			}
+		)
+		names(object at parameters$coefficients) <- nms
+		return(object)
+	}
+)
+setMethod("getpars","MVNresponse",
+	function(object,which="pars",...) {
+		switch(which,
+			"pars" = {
+				parameters <- numeric()
+				parameters <- unlist(object at parameters)
+				pars <- parameters
+			},
+			"fixed" = {
+				pars <- object at fixed
+			}
+		)
+		return(pars)
+	}
+)
Modified: pkg/man/depmix-internal.Rd
===================================================================
--- pkg/man/depmix-internal.Rd	2008-07-01 12:33:16 UTC (rev 209)
+++ pkg/man/depmix-internal.Rd	2008-07-01 14:08:44 UTC (rev 210)
@@ -52,6 +52,10 @@
 \alias{getpars,GLMresponse-method}
 \alias{setpars,GLMresponse-method}
 
+\alias{getpars,MVNresponse-method}
+\alias{setpars,MVNresponse-method}
+
+
 \alias{npar,response-method}
 
 \title{Depmix internal functions}

Modified: trunk/R/getpars.R
===================================================================
--- trunk/R/getpars.R	2008-07-01 12:33:16 UTC (rev 209)
+++ trunk/R/getpars.R	2008-07-01 14:08:44 UTC (rev 210)
@@ -1,16 +1,26 @@
 setMethod("getpars","mix",
 	function(object,which="pars",...) {
 		parameters <- getpars(object at prior,which=which)
-		if(class(object)=="depmix"|class(object)=="depmix.fitted") {
-			for(i in 1:object at nstates) {
-				parameters <- c(parameters,getpars(object at transition[[i]],which=which))
+		for(i in 1:object at nstates) {
+			for(j in 1:object at nresp) {
+				parameters <- c(parameters,getpars(object at response[[i]][[j]],which=which))
 			}
-		}	
+		}
+		return(parameters)
+	}
+)
+
+setMethod("getpars","depmix",
+	function(object,which="pars",...) {
+		parameters <- getpars(object at prior,which=which)
 		for(i in 1:object at nstates) {
+			parameters <- c(parameters,getpars(object at transition[[i]],which=which))
+		}
+		for(i in 1:object at nstates) {
 			for(j in 1:object at nresp) {
 				parameters <- c(parameters,getpars(object at response[[i]][[j]],which=which))
 			}
 		}
 		return(parameters)
 	}
-)
+)
\ No newline at end of file

Modified: trunk/R/responseGLM.R
===================================================================
--- trunk/R/responseGLM.R	2008-07-01 12:33:16 UTC (rev 209)
+++ trunk/R/responseGLM.R	2008-07-01 14:08:44 UTC (rev 210)
@@ -130,6 +130,7 @@
 		npar <- npar(object)
 		if(length(values)!=npar) stop("length of 'values' must be",npar)
 		# determine whether parameters or fixed constraints are being set
+		nms <- names(object at parameters$coefficients)
 		switch(which,
 			"pars"= {
 				if(object at family$family=="multinomial") {
@@ -145,13 +146,14 @@
 					object at parameters$coefficients <- values[1:length(object at parameters$coefficients)]
 				}
 				if(length(unlist(object at parameters))>length(object at parameters$coefficients)) {
-					if(object at family$family=="gaussian") object at parameters$sd <- values[(length(object at parameters$coefficients)+1)]
+					if(object at family$family=="gaussian") object at parameters$sd <- as.numeric(values[(length(object at parameters$coefficients)+1)])
 				}
 			},
 			"fixed" = {
 				object at fixed <- as.logical(values)
 			}
 		)
+		names(object at parameters$coefficients) <- nms
 		return(object)
 	}
 )
Modified: trunk/R/responseMVN.R
===================================================================
--- trunk/R/responseMVN.R	2008-07-01 12:33:16 UTC (rev 209)
+++ trunk/R/responseMVN.R	2008-07-01 14:08:44 UTC (rev 210)
@@ -132,4 +132,40 @@
 	}
 )
 
-#TODO: setpars function
+setMethod("setpars","MVNresponse",
+	function(object, values, which="pars", prob=FALSE, ...) {
+		npar <- npar(object)
+		if(length(values)!=npar) stop("length of 'values' must be",npar)
+		# determine whether parameters or fixed constraints are being set
+		nms <- names(object at parameters$coefficients)
+		switch(which,
+			"pars" = {
+				object at parameters$coefficients <- matrix(values[1:length(object at parameters$coefficients)],ncol(object at x))
+			  if(length(unlist(object at parameters))>length(object at parameters$coefficients)) {
+          st <- length(object at parameters$coefficients)+1
+          object at parameters$Sigma <- matrix(as.numeric(values[st:(st+length(object at parameters$Sigma))]),ncol=ncol(object at parameters$Sigma),nrow=nrow(object at parameters$Sigma))
+			  }
+			},
+			"fixed" = {
+				object at fixed <- as.logical(values)
+			}
+		)
+		names(object at parameters$coefficients) <- nms
+		return(object)
+	}
+)
+setMethod("getpars","MVNresponse",
+	function(object,which="pars",...) {
+		switch(which,
+			"pars" = {
+				parameters <- numeric()
+				parameters <- unlist(object at parameters)
+				pars <- parameters
+			},
+			"fixed" = {
+				pars <- object at fixed
+			}
+		)
+		return(pars)
+	}
+)
Modified: trunk/man/depmix-internal.Rd
===================================================================
--- trunk/man/depmix-internal.Rd	2008-07-01 12:33:16 UTC (rev 209)
+++ trunk/man/depmix-internal.Rd	2008-07-01 14:08:44 UTC (rev 210)
@@ -52,6 +52,10 @@
 \alias{getpars,GLMresponse-method}
 \alias{setpars,GLMresponse-method}
 
+\alias{getpars,MVNresponse-method}
+\alias{setpars,MVNresponse-method}
+
+
 \alias{npar,response-method}
 
 \title{Depmix internal functions}