[Robkalman-commits] r64 - branches/robKalman_2012/pkg/robKalman/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Apr 23 10:05:48 CEST 2013
Author: bspangl
Date: 2013-04-23 10:05:48 +0200 (Tue, 23 Apr 2013)
New Revision: 64
Modified:
branches/robKalman_2012/pkg/robKalman/R/Fmethods.R
branches/robKalman_2012/pkg/robKalman/R/Qmethods.R
branches/robKalman_2012/pkg/robKalman/R/Vmethods.R
branches/robKalman_2012/pkg/robKalman/R/Zmethods.R
Log:
several updates and changes (Teil 2)
Modified: branches/robKalman_2012/pkg/robKalman/R/Fmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2013-04-19 13:03:08 UTC (rev 63)
+++ branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2013-04-23 08:05:48 UTC (rev 64)
@@ -1,5 +1,7 @@
### time-invariant case, linear
-setMethod("createF", "matrix", function (object, R = NULL)
+setMethod("createF", "matrix",
+function (object, R = NULL,
+ controlF = list(whenEvaluExo=c("pre"=TRUE, "post"=FALSE)), ...)
{
## F ... matrix of state equation
## R ... selection matrix (cf. Durbin & Koopman, 2001, p.38)
@@ -9,12 +11,15 @@
R <- diag(nrow(F))
}
- funcF <- function (t, x0, v=rep(0, ncol(R)),
- uFct, uOld=NULL, wNew=NULL,
- control=list(whenEvaluExo=c("pre"=TRUE, "post"=FALSE)),
- dots=NULL)
+ dots.propagated <- list(...)
+
+ funcF <- function (i, t, x0, v=rep(0, ncol(R)),
+ uFct=NULL, uOld=NULL, wNew=NULL,
+ control=controlF,
+ dots=dots.propagated)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x0 ... filter estimate x_{t-1|t-1}, vector
## v ... innovations v_t, vector!
## uFct ... function of exogenous variable u, yields vector u_t
@@ -24,8 +29,10 @@
## dots ... additional parameters, list
call <- match.call()
+ if (is.null(uFct)) uFct <- createuExo(0)
+
if (control$whenEvaluExo["pre"]) {
- u <- uFct(t=t, x0=x0, uOld=uOld, wNew=wNew)
+ u <- uFct(i=i, t=t, x0=x0, uOld=uOld, wNew=wNew)
} else {
u <- uOld
}
@@ -33,7 +40,7 @@
x1 <- F%*%x0 + u + R%*%v
if (control$whenEvaluExo["post"]) {
- u <- uFct(t=t, x0=as.vector(x1), uOld=uOld, wNew=wNew)
+ u <- uFct(i=i, t=t, x0=as.vector(x1), uOld=uOld, wNew=wNew)
}
retF <- new("SSretValueF",
@@ -48,7 +55,9 @@
### time-variant case, linear
-setMethod("createF", "array", function (object, R = NULL)
+setMethod("createF", "array",
+function (object, R = NULL,
+ controlF = list(whenEvaluExo=c("pre"=TRUE, "post"=FALSE)), ...)
{
## F ... array of state equation, F[, , t]
## R ... selection matrix array (cf. Durbin & Koopman, 2001, p.38)
@@ -63,12 +72,15 @@
R <- array(diag(nrowF), dim=c(nrowF, nrowF, dim(F)[3]))
}
- funcF <- function (t, x0, v=rep(0, ncol(R[, , t])),
- uFct, uOld=NULL, wNew=NULL,
- control=list(whenEvaluExo=c("pre"=TRUE, "post"=FALSE)),
- dots=NULL)
+ dots.propagated <- list(...)
+
+ funcF <- function (i, t, x0, v=rep(0, ncol(R[, , t])),
+ uFct=NULL, uOld=NULL, wNew=NULL,
+ control=controlF,
+ dots=dots.propagated)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x0 ... filter estimate x_{t-1|t-1}, vector
## v ... innovations v_t, vector!
## uFct ... function of exogenous variable u, yields vector u_t
@@ -78,21 +90,23 @@
## dots ... additional parameters, list
call <- match.call()
+ if (is.null(uFct)) uFct <- createuExo(0)
+
if (control$whenEvaluExo["pre"]) {
- u <- uFct(t=t, x0=x0, uOld=uOld, wNew=wNew)
+ u <- uFct(i=i, t=t, x0=x0, uOld=uOld, wNew=wNew)
} else {
u <- uOld
}
- x1 <- F[, , t]%*%x0 + u + R[, , t]%*%v
+ x1 <- F[, , i]%*%x0 + u + R[, , i]%*%v
if (control$whenEvaluExo["post"]) {
- u <- uFct(t=t, x0=as.vector(x1), uOld=uOld, wNew=wNew)
+ u <- uFct(i=i, t=t, x0=as.vector(x1), uOld=uOld, wNew=wNew)
}
retF <- new("SSretValueF",
- x1 = as.vector(x1), FJcb = F[, , t, drop=TRUE],
- RJcb = R[, , t, drop=TRUE], t = t, x0 = x0,
+ x1 = as.vector(x1), FJcb = F[, , i, drop=TRUE],
+ RJcb = R[, , i, drop=TRUE], t = t, x0 = x0,
v = v, uNew = u, control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
@@ -108,12 +122,13 @@
## F ... function, F(t, x0, ...)
F <- object
- funcF <- function (t, x0, v=0,
+ funcF <- function (i=NULL, t, x0, v=0,
uFct=NULL, uOld=NULL, wNew=NULL,
control=NULL,
dots=NULL)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x0 ... filter estimate x_{t-1|t-1}, vector
## v ... innovations v_t, vector!
## uFct ... function of exogenous variable u, yields vector u_t
@@ -123,7 +138,9 @@
## dots ... additional parameters, list
call <- match.call()
- ret0 <- F(t, x0, v, uFct, uOld, wNew, control, dots)
+ ret0 <- F(i=i, t=t, x0=x0, v=v,
+ uFct=uFct, uOld=uOld, wNew=wNew,
+ control=control, dots=dots)
if (is(ret0, "SSretValueF")) return(ret0)
retF <- new("SSretValueF",
Modified: branches/robKalman_2012/pkg/robKalman/R/Qmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2013-04-19 13:03:08 UTC (rev 63)
+++ branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2013-04-23 08:05:48 UTC (rev 64)
@@ -1,12 +1,19 @@
### time-invariant case, linear
-setMethod("createQ", "matrix", function (object)
+setMethod("createQ", "matrix",
+function (object,
+ controlQ = NULL, ...)
{
## Q ... covariance matrix of innovations
Q <- object
- funcQ <- function (t, x0, control=NULL, dots=NULL)
+ dots.propagated <- list(...)
+
+ funcQ <- function (i, t, x0,
+ control=controlQ,
+ dots=dots.propagated)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x0 ... filter estimate x_{t-1|t-1}, vector
## control ... control parameters, list
## dots ... additional parameters, list
@@ -25,21 +32,28 @@
### time-variant case, linear
-setMethod("createQ", "array", function (object)
+setMethod("createQ", "array",
+function (object,
+ controlQ = NULL, ...)
{
## Q ... array of covariance matrices of innovations, Q[, , t]
Q <- object
- funcQ <- function (t, x0, control=NULL, dots=NULL)
+ dots.propagated <- list(...)
+
+ funcQ <- function (i, t, x0,
+ control=controlQ,
+ dots=dots.propagated)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x0 ... filter estimate x_{t-1|t-1}, vector
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
retQ <- new("SSretValueQ",
- Q = Q[, , t, drop=TRUE], t = t,
+ Q = Q[, , i, drop=TRUE], t = t,
x0 = x0,
control = control,
dots.propagated = dots, call = call,
@@ -56,15 +70,17 @@
## Q ... function, Q(t, ...)
Q <- object
- funcQ <- function (t, x0=0, control=NULL, dots=NULL)
+ funcQ <- function (i=NULL, t, x0=0, control=NULL, dots=NULL)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x0 ... filter estimate x_{t-1|t-1}, vector
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
- ret0 <- Q(t, x0, control, dots)
+ ret0 <- Q(i=i, t=t, x0=x0,
+ control=control, dots=dots)
if (is(ret0, "SSretValueQ")) return(ret0)
retQ <- new("SSretValueQ",
Modified: branches/robKalman_2012/pkg/robKalman/R/Vmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2013-04-19 13:03:08 UTC (rev 63)
+++ branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2013-04-23 08:05:48 UTC (rev 64)
@@ -1,13 +1,20 @@
### time-invariant case, linear
-setMethod("createV", "matrix", function (object)
+setMethod("createV", "matrix",
+function (object,
+ controlV = NULL, ...)
{
## V ... covariance matrix of innovations
V <- object
- funcV <- function(t, x1, control=NULL, dots=NULL)
+ dots.propagated <- list(...)
+
+ funcV <- function(i, t, x1,
+ control=controlV,
+ dots=dots.propagated)
{
- ## t ... time index
- ## x0 ... filter estimate x_{t-1|t-1}, vector
+ ## i ... loop index
+ ## t ... time, t[i]
+ ## x1 ... one-step ahead predictor x_{t|t-1}, vector
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
@@ -15,7 +22,7 @@
retV <- new("SSretValueV",
V = V, t = t,
x1 = x1,
- control=control,
+ control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
return(retV)
@@ -25,21 +32,28 @@
### time-variant case, linear
-setMethod("createV", "array", function (object)
+setMethod("createV", "array",
+function (object,
+ controlV = NULL, ...)
{
## V ... array of covariance matrices of innovations, V[, , t]
V <- object
- funcV <- function(t, x1, control=NULL, dots=NULL)
+ dots.propagated <- list(...)
+
+ funcV <- function(i, t, x1,
+ control=controlV,
+ dots=dots.propagated)
{
- ## t ... time index
- ## x0 ... filter estimate x_{t-1|t-1}, vector
+ ## i ... loop index
+ ## t ... time, t[i]
+ ## x1 ... one-step ahead predictor x_{t|t-1}, vector
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
retV <- new("SSretValueV",
- V = V[, , t, drop=TRUE], t = t,
+ V = V[, , i, drop=TRUE], t = t,
x1 = x1,
control = control,
dots.propagated = dots, call = call,
@@ -56,15 +70,17 @@
## V ... function, V(t, ...)
V <- object
- funcV <- function(t, x1=0, control=NULL, dots=NULL)
+ funcV <- function(i=NULL, t, x1=0, control=NULL, dots=NULL)
{
- ## t ... time index
- ## x0 ... filter estimate x_{t-1|t-1}, vector
+ ## i ... loop index
+ ## t ... time, t[i]
+ ## x1 ... one-step ahead predictor x_{t|t-1}, vector
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
- ret0 <- V(t, x1, control, dots)
+ ret0 <- V(i=i, t=t, x1=x1,
+ control=control, dots=dots)
if (is(ret0, "SSretValueV")) return(ret0)
retV <- new("SSretValueV",
Modified: branches/robKalman_2012/pkg/robKalman/R/Zmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Zmethods.R 2013-04-19 13:03:08 UTC (rev 63)
+++ branches/robKalman_2012/pkg/robKalman/R/Zmethods.R 2013-04-23 08:05:48 UTC (rev 64)
@@ -1,5 +1,7 @@
### time-invariant case, linear
-setMethod("createZ", "matrix", function (object, T = NULL)
+setMethod("createZ", "matrix",
+function (object, T = NULL,
+ controlZ = list(whenEvalwExo=c("pre"=TRUE, "post"=FALSE)), ...)
{
## Z ... observation matrix
## T ... selection matrix (observation noise)
@@ -9,13 +11,17 @@
T <- diag(nrow(Z))
}
- funcZ <- function (t, x1, eps=rep(0, ncol(T)),
- wFct, uNew=NULL, wOld=NULL,
- control=list(whenEvalwExo=c("pre"=TRUE, "post"=FALSE)),
- dots=NULL)
+ dots.propagated <- list(...)
+
+ funcZ <- function (i, t, x1, y, eps=rep(0, ncol(T)),
+ wFct=NULL, uNew=NULL, wOld=NULL,
+ control=controlZ,
+ dots=dots.propagated)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x1 ... one-step ahead predictor x_{t|t-1}, vector
+ ## y ... observations y_t
## eps ... observation noise \eps_t, vector!
## wFct ... function of exogenous variable w, yields vector w_t
## uNew ... exogenous variable u_t, vector!
@@ -24,20 +30,22 @@
## dots ... additional parameters, list
call <- match.call()
+ if (is.null(wFct)) wFct <- createwExo(0)
+
if (control$whenEvalwExo["pre"]) {
- w <- wFct(t=t, x1=x1, uNew=uNew, wOld=wOld)
+ w <- wFct(i=i, t=t, x1=x1, y=y, uNew=uNew, wOld=wOld)
} else {
w <- wOld
}
- y <- as.vector(Z%*%x1 + w + T%*%eps)
+ yhat <- as.vector(Z%*%x1 + w + T%*%eps)
if (control$whenEvalwExo["post"]) {
- w <- wFct(t=t, x1=x1, uNew=uNew, wOld=wOld)
+ w <- wFct(i=i, t=t, x1=x1, y=yhat, uNew=uNew, wOld=wOld)
}
retZ <- new("SSretValueZ",
- y = y, ZJcb = Z, TJcb = T,
+ y = yhat, ZJcb = Z, TJcb = T,
t = t, x1 = x1, eps = eps, wNew = w, control=control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
@@ -48,7 +56,9 @@
### time-variant case, linear
-setMethod("createZ", "array", function (object, T = NULL)
+setMethod("createZ", "array",
+function (object, T = NULL,
+ controlZ = list(whenEvalwExo=c("pre"=TRUE, "post"=FALSE)), ...)
{
## Z ... array of observation matrices, Z[, , t]
## T ... selection matrix array (observation noise)
@@ -63,13 +73,17 @@
T <- array(diag(nrowZ), dim=c(nrowZ, nrowZ, dim(Z)[3]))
}
- funcZ <- function (t, x1, eps=rep(0, ncol(T[, , t])),
- wFct, uNew=NULL, wOld=NULL,
- control=list(whenEvalwExo=c("pre"=TRUE, "post"=FALSE)),
- dots=NULL)
+ dots.propagated <- list(...)
+
+ funcZ <- function (i, t, x1, y, eps=rep(0, ncol(T[, , t])),
+ wFct=NULL, uNew=NULL, wOld=NULL,
+ control=controlZ,
+ dots=dots.propagated)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x1 ... one-step ahead predictor x_{t|t-1}, vector
+ ## y ... observations, y_t
## eps ... observation noise \eps_t, vector!
## wFct ... function of exogenous variable w, yields vector w_t
## uNew ... exogenous variable u_t, vector!
@@ -78,21 +92,23 @@
## dots ... additional parameters, list
call <- match.call()
+ if (is.null(wFct)) wFct <- createwExo(0)
+
if (control$whenEvalwExo["pre"]) {
- w <- wFct(t=t, x1=x1, uNew=uNew, wOld=wOld)
+ w <- wFct(i=i, t=t, x1=x1, y=y, uNew=uNew, wOld=wOld)
} else {
w <- wOld
}
- y <- as.vector(Z[, , t]%*%x1 + w + T[, , t]%*%eps)
+ yhat <- as.vector(Z[, , i]%*%x1 + w + T[, , i]%*%eps)
if (control$whenEvalwExo["post"]) {
- w <- wFct(t=t, x1=x1, uNew=uNew, wOld=wOld)
+ w <- wFct(i=i, t=t, x1=x1, y=yhat, uNew=uNew, wOld=wOld)
}
retZ <- new("SSretValueZ",
- y = y, ZJcb = Z[, , t, drop=TRUE],
- TJcb = T[, , t, drop=TRUE], t = t, x1 = x1,
+ y = yhat, ZJcb = Z[, , i, drop=TRUE],
+ TJcb = T[, , i, drop=TRUE], t = t, x1 = x1,
eps = eps, wNew = w, control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
@@ -108,13 +124,15 @@
## Z ... function , Z(t, x1, ...)
Z <- object
- funcZ <- function (t, x1, eps=0,
+ funcZ <- function (i=NULL, t, x1, y=NULL, eps=0,
wFct=NULL, uNew=NULL, wOld=NULL,
control=NULL,
dots=NULL)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x1 ... one-step ahead predictor x_{t|t-1}, vector
+ ## y ... observations, y_t
## eps ... observation noise \eps_t, vector!
## wFct ... function of exogenous variable w, yields vector w_t
## uNew ... exogenous variable u_t, vector!
@@ -123,7 +141,9 @@
## dots ... additional parameters, list
call <- match.call()
- ret0 <- Z(t, x1, eps, wFct, uNew, wOld, control, dots)
+ ret0 <- Z(i=i, t=t, x1=x1, y=y, eps=eps,
+ wFct=wFct, uNew=uNew, wOld=wOld,
+ control=control, dots=dots)
if (is(ret0, "SSretValueZ")) return(ret0)
retZ <- new("SSretValueZ",
@@ -134,6 +154,5 @@
diagnostics = new("SSDiagnosticRetValue"))
return(retZ)
}
-
return(new("FunctionWithControl",funcZ))
})
More information about the Robkalman-commits
mailing list