[Robkalman-commits] r61 - branches/robKalman_2012/pkg/robKalman/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Sat Apr 6 20:11:07 CEST 2013
Author: bspangl
Date: 2013-04-06 20:11:06 +0200 (Sat, 06 Apr 2013)
New Revision: 61
Added:
branches/robKalman_2012/pkg/robKalman/R/uExomethods.R
branches/robKalman_2012/pkg/robKalman/R/wExomethods.R
Modified:
branches/robKalman_2012/pkg/robKalman/R/AllGenerics.R
branches/robKalman_2012/pkg/robKalman/R/Fmethods.R
branches/robKalman_2012/pkg/robKalman/R/Qmethods.R
branches/robKalman_2012/pkg/robKalman/R/StepFunct.R
branches/robKalman_2012/pkg/robKalman/R/Vmethods.R
branches/robKalman_2012/pkg/robKalman/R/Zmethods.R
branches/robKalman_2012/pkg/robKalman/R/allClass.R
Log:
several updates and changes
Modified: branches/robKalman_2012/pkg/robKalman/R/AllGenerics.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/AllGenerics.R 2013-04-03 12:47:07 UTC (rev 60)
+++ branches/robKalman_2012/pkg/robKalman/R/AllGenerics.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -25,6 +25,10 @@
setGeneric("Q", function(object, ...) standardGeneric("Q"))
if(!isGeneric("V"))
setGeneric("V", function(object, ...) standardGeneric("V"))
+if(!isGeneric("createuExo"))
+ setGeneric("createuExo", function(object, ...) standardGeneric("createuExo"))
+if(!isGeneric("createwExo"))
+ setGeneric("createwExo", function(object, ...) standardGeneric("createwExo"))
if(!isGeneric("createF"))
setGeneric("createF", function(object, ...) standardGeneric("createF"))
if(!isGeneric("createZ"))
Modified: branches/robKalman_2012/pkg/robKalman/R/Fmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2013-04-03 12:47:07 UTC (rev 60)
+++ branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -9,21 +9,36 @@
R <- diag(nrow(F))
}
- funcF <- function (t, x0, v, u, control, dots)
+ funcF <- function (t, x0, v=rep(0, ncol(R)),
+ uFct, uOld=NULL, wNew=NULL,
+ control=list(whenEvaluExo=c("pre"=TRUE, "post"=FALSE)),
+ dots=NULL)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
## v ... innovations v_t, vector!
- ## u ... exogenous variable u_{t-1}, vector!
+ ## uFct ... function of exogenous variable u, yields vector u_t
+ ## uOld ... exogenous variable u_{t-1}, vector!
+ ## wNew ... exogenous variable w_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
+ if (control$whenEvaluExo["pre"]) {
+ u <- uFct(t=t, x0=x0, uOld=uOld, wNew=wNew)
+ } else {
+ u <- uOld
+ }
+
x1 <- F%*%x0 + u + R%*%v
+ if (control$whenEvaluExo["post"]) {
+ u <- uFct(t=t, x0=as.vector(x1), uOld=uOld, wNew=wNew)
+ }
+
retF <- new("SSretValueF",
- x1 = as.vector(x1), Fmat = F, Rmat = R,
- t=t, x0=x0, v = v, u = u, control=control,
+ x1 = as.vector(x1), FJcb = F, RJcb = R,
+ t = t, x0 = x0, v = v, uNew = u, control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
return(retF)
@@ -48,22 +63,37 @@
R <- array(diag(nrowF), dim=c(nrowF, nrowF, dim(F)[3]))
}
- funcF <- function (t, x0, v, u, control, dots)
+ 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)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
## v ... innovations v_t, vector!
- ## u ... exogenous variable u_{t-1}, vector!
+ ## uFct ... function of exogenous variable u, yields vector u_t
+ ## uOld ... exogenous variable u_{t-1}, vector!
+ ## wNew ... exogenous variable w_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
+ if (control$whenEvaluExo["pre"]) {
+ u <- uFct(t=t, x0=x0, uOld=uOld, wNew=wNew)
+ } else {
+ u <- uOld
+ }
+
x1 <- F[, , t]%*%x0 + u + R[, , t]%*%v
+ if (control$whenEvaluExo["post"]) {
+ u <- uFct(t=t, x0=as.vector(x1), uOld=uOld, wNew=wNew)
+ }
+
retF <- new("SSretValueF",
- x1 = as.vector(x1), Fmat = F[, , t, drop=TRUE],
- Rmat = R[, , t, drop=TRUE], t = t, x0 = x0,
- v = v, u = u, control = control,
+ x1 = as.vector(x1), FJcb = F[, , t, drop=TRUE],
+ RJcb = R[, , t, drop=TRUE], t = t, x0 = x0,
+ v = v, uNew = u, control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
return(retF)
@@ -75,26 +105,31 @@
### function case
setMethod("createF", "function", function (object)
{
-## F ... function, F(t, x0, v, u, control, dots)
+## F ... function, F(t, x0, ...)
F <- object
- funcF <- function (t, x0, v, u, control, dots)
+ funcF <- function (t, x0, v=0,
+ uFct=NULL, uOld=NULL, wNew=NULL,
+ control=NULL,
+ dots=NULL)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
## v ... innovations v_t, vector!
- ## u ... exogenous variable u_{t-1}, vector!
+ ## uFct ... function of exogenous variable u, yields vector u_t
+ ## uOld ... exogenous variable u_{t-1}, vector!
+ ## wNew ... exogenous variable w_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
- ret0 <- F(t, x0, v, u, control, dots)
+ ret0 <- F(t, x0, v, uFct, uOld, wNew, control, dots)
if (is(ret0, "SSretValueF")) return(ret0)
retF <- new("SSretValueF",
- x1 = ret0$x1, Fmat = ret0$A,
- Rmat = ret0$B, t = t, x0 = x0,
- v = v, u = u, control = control,
+ x1 = ret0$x1, FJcb = ret0$A,
+ RJcb = ret0$B, t = t, x0 = x0,
+ v = v, uNew = ret0$uNew, control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
return(retF)
Modified: branches/robKalman_2012/pkg/robKalman/R/Qmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2013-04-03 12:47:07 UTC (rev 60)
+++ branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -4,18 +4,17 @@
## Q ... covariance matrix of innovations
Q <- object
- funcQ <- function (t, x0, exQ, control, dots)
+ funcQ <- function (t, x0, control=NULL, dots=NULL)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
- ## exQ ... exogenous variable exQ_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
retQ <- new("SSretValueQ",
- Q = Q, t=t,
- x0 = x0, exQ = exQ,
+ Q = Q, t = t,
+ x0 = x0,
control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
@@ -31,18 +30,18 @@
## Q ... array of covariance matrices of innovations, Q[, , t]
Q <- object
- funcQ <- function (t, x0, exQ, control, dots)
+ funcQ <- function (t, x0, control=NULL, dots=NULL)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
- ## exQ ... exogenous variable exQ_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
retQ <- new("SSretValueQ",
Q = Q[, , t, drop=TRUE], t = t,
- x0 = x0, exQ = exQ, control = control,
+ x0 = x0,
+ control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
return(retQ)
@@ -54,28 +53,27 @@
### function case
setMethod("createQ", "function", function (object)
{
-## Q ... covariance matrix of innovations
-
+## Q ... function, Q(t, ...)
Q <- object
- funcQ <- function (t, x0, exQ, control, dots)
+ funcQ <- function (t, x0=0, control=NULL, dots=NULL)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
- ## exQ ... exogenous variable exQ_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
- ret0 <- Q(t, x0, exQ, control, dots)
+ ret0 <- Q(t, x0, control, dots)
+ if (is(ret0, "SSretValueQ")) return(ret0)
- retQ <- new("SSretValueQ", Q = ret0$Q, t=t,
- x0 = x0, exQ = exQ,
- control=control, dots = dots, call = call,
- diagnostics = list())
-
+ retQ <- new("SSretValueQ",
+ Q = ret0$Q, t = t,
+ x0 = x0,
+ control=control,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retQ)
}
-
return(new("FunctionWithControl",funcQ))
})
Modified: branches/robKalman_2012/pkg/robKalman/R/StepFunct.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/StepFunct.R 2013-04-03 12:47:07 UTC (rev 60)
+++ branches/robKalman_2012/pkg/robKalman/R/StepFunct.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -59,12 +59,12 @@
## wOld (unveraendert vom Input 'Pred-Step')
## control ... control argument of step function
- fctPredS <- function (i, PredOrFilt, statesEq, controlPred=control,
+ fctPredS <- function (i, PredOrFilt, stateEq, controlPred=control,
whenEvalExo =c("pre"=TRUE, "post"=FALSE), ...)
{
## i ... time index
## PredOrFilt ... object of S4 class 'SSPredOrFilt'
- ## statesEq ... object of S4 class 'SSstatesEq'
+ ## stateEq ... object of S4 class 'SSstateEq'
## controlPred ... control parameters, list
call <- match.call()
dots.propagated <- list(...)
Modified: branches/robKalman_2012/pkg/robKalman/R/Vmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2013-04-03 12:47:07 UTC (rev 60)
+++ branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -4,18 +4,17 @@
## V ... covariance matrix of innovations
V <- object
- funcV <- function(t, x1, exV, control, dots)
+ funcV <- function(t, x1, control=NULL, dots=NULL)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
- ## exV ... exogenous variable exV_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
retV <- new("SSretValueV",
- V = V, t=t,
- x1 = x1, exV = exV,
+ V = V, t = t,
+ x1 = x1,
control=control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
@@ -31,18 +30,18 @@
## V ... array of covariance matrices of innovations, V[, , t]
V <- object
- funcV <- function(t, x1, exV, control, dots)
+ funcV <- function(t, x1, control=NULL, dots=NULL)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
- ## exV ... exogenous variable exV_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
retV <- new("SSretValueV",
V = V[, , t, drop=TRUE], t = t,
- x1 = x1, exV = exV, control = control,
+ x1 = x1,
+ control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
return(retV)
@@ -54,29 +53,27 @@
### function case
setMethod("createV", "function", function (object)
{
-## V ... covariance matrix of innovations
-
+## V ... function, V(t, ...)
V <- object
- funcV <- function(t, x1, exV, control, dots)
+ funcV <- function(t, x1=0, control=NULL, dots=NULL)
{
## t ... time index
## x0 ... filter estimate x_{t-1|t-1}, vector
- ## exV ... exogenous variable exV_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
- ret0 <- V(t, x1, exV, control, dots)
+ ret0 <- V(t, x1, control, dots)
+ if (is(ret0, "SSretValueV")) return(ret0)
- retV <- new("SSretValueV", V = ret0$V, t=t,
- x1 = x1, exV = exV,
- control=control, dots = dots, call = call,
- diagnostics = list())
-
+ retV <- new("SSretValueV",
+ V = ret0$V, t = t,
+ x1 = x1,
+ control=control,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retV)
}
-
return(new("FunctionWithControl",funcV))
-
})
Modified: branches/robKalman_2012/pkg/robKalman/R/Zmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Zmethods.R 2013-04-03 12:47:07 UTC (rev 60)
+++ branches/robKalman_2012/pkg/robKalman/R/Zmethods.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -9,21 +9,36 @@
T <- diag(nrow(Z))
}
- funcZ <- function (t, x1, eps, w, control, dots)
+ funcZ <- function (t, x1, eps=rep(0, ncol(T)),
+ wFct, uNew=NULL, wOld=NULL,
+ control=list(whenEvalwExo=c("pre"=TRUE, "post"=FALSE)),
+ dots=NULL)
{
## t ... time index
## x1 ... one-step ahead predictor x_{t|t-1}, vector
## eps ... observation noise \eps_t, vector!
- ## w ... exogenous variable w_t, vector!
+ ## wFct ... function of exogenous variable w, yields vector w_t
+ ## uNew ... exogenous variable u_t, vector!
+ ## wOld ... exogenous variable w_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
- y <- Z%*%x1 + w + T%*%eps
+ if (control$whenEvalwExo["pre"]) {
+ w <- wFct(t=t, x1=x1, uNew=uNew, wOld=wOld)
+ } else {
+ w <- wOld
+ }
- retZ <- new("SSretValueZ", y = as.vector(y), Zmat = Z,
- Tmat = T, t=t, x1 = x1, eps = eps, w = w,
- control=control,
+ y <- as.vector(Z%*%x1 + w + T%*%eps)
+
+ if (control$whenEvalwExo["post"]) {
+ w <- wFct(t=t, x1=x1, uNew=uNew, wOld=wOld)
+ }
+
+ retZ <- new("SSretValueZ",
+ y = y, ZJcb = Z, TJcb = T,
+ t = t, x1 = x1, eps = eps, wNew = w, control=control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
return(retZ)
@@ -48,21 +63,37 @@
T <- array(diag(nrowZ), dim=c(nrowZ, nrowZ, dim(Z)[3]))
}
- funcZ <- function (t, x1, eps, w, control, dots)
+ 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)
{
## t ... time index
## x1 ... one-step ahead predictor x_{t|t-1}, vector
## eps ... observation noise \eps_t, vector!
- ## w ... exogenous variable w_t, vector!
+ ## wFct ... function of exogenous variable w, yields vector w_t
+ ## uNew ... exogenous variable u_t, vector!
+ ## wOld ... exogenous variable w_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
- y <- Z[, , t]%*%x1 + w + T[, , t]%*%eps
+ if (control$whenEvalwExo["pre"]) {
+ w <- wFct(t=t, x1=x1, uNew=uNew, wOld=wOld)
+ } else {
+ w <- wOld
+ }
- retZ <- new("SSretValueZ", y = y, Zmat = Z[, , t, drop=TRUE],
- Tmat = T[, , t, drop=TRUE], t = t, x1 = x1,
- eps = eps, w = w, control = control,
+ y <- as.vector(Z[, , t]%*%x1 + w + T[, , t]%*%eps)
+
+ if (control$whenEvalwExo["post"]) {
+ w <- wFct(t=t, x1=x1, uNew=uNew, wOld=wOld)
+ }
+
+ retZ <- new("SSretValueZ",
+ y = y, ZJcb = Z[, , t, drop=TRUE],
+ TJcb = T[, , t, drop=TRUE], t = t, x1 = x1,
+ eps = eps, wNew = w, control = control,
dots.propagated = dots, call = call,
diagnostics = new("SSDiagnosticRetValue"))
return(retZ)
@@ -74,28 +105,33 @@
### function case
setMethod("createZ", "function", function (object)
{
-## Z ... observation matrix
-## T ... selection matrix (observation noise)
+## Z ... function , Z(t, x1, ...)
Z <- object
- ### some Z checking possible and needed
-
- funcZ <- function (t, x1, eps, w, control, dots)
+ funcZ <- function (t, x1, eps=0,
+ wFct=NULL, uNew=NULL, wOld=NULL,
+ control=NULL,
+ dots=NULL)
{
## t ... time index
## x1 ... one-step ahead predictor x_{t|t-1}, vector
## eps ... observation noise \eps_t, vector!
- ## w ... exogenous variable w_t, vector!
+ ## wFct ... function of exogenous variable w, yields vector w_t
+ ## uNew ... exogenous variable u_t, vector!
+ ## wOld ... exogenous variable w_{t-1}, vector!
## control ... control parameters, list
## dots ... additional parameters, list
call <- match.call()
- ret0 <- Z(t, x1, eps, w, control, dots)
+ ret0 <- Z(t, x1, eps, wFct, uNew, wOld, control, dots)
+ if (is(ret0, "SSretValueZ")) return(ret0)
- retZ <- new("SSretValueZ", y = ret0$y, Z = ret0$Z,
- T = NULL, t=t, x1 = x1, eps = eps, w = w,
- control=control, dots = dots, call = call,
- diagnostics = list())
+ retZ <- new("SSretValueZ",
+ y = ret0$y, ZJcb = ret0$C,
+ TJcb = ret$D, t = t, x1 = x1,
+ eps = eps, wNew = ret0$wNew, control=control,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retZ)
}
Modified: branches/robKalman_2012/pkg/robKalman/R/allClass.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/allClass.R 2013-04-03 12:47:07 UTC (rev 60)
+++ branches/robKalman_2012/pkg/robKalman/R/allClass.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -58,21 +58,21 @@
representation = representation(Ffct = "FunctionWithControl",
Qfct = "FunctionWithControl",
muqfct = "OptionalFunction",
- Exofct = "OptionalFunctionWithControl",
- distrfct = "OptionalDistribution")
+ distrfct = "OptionalDistribution",
+ uExofct = "OptionalFunctionWithControl")
)
setClass("SSobsEq",
representation = representation(Zfct = "FunctionWithControl",
Vfct = "FunctionWithControl",
muvfct = "OptionalFunction",
- Exofct = "OptionalFunctionWithControl",
- distrfct = "OptionalDistribution")
+ distrfct = "OptionalDistribution",
+ wExofct = "OptionalFunctionWithControl")
)
setClass("SSinitEq",
representation = representation(a0 = "numeric",
Sigma0 = "matrix",
- Exofct = "OptionalFunctionWithControl",
- distrfct = "OptionalDistribution")
+ distrfct = "OptionalDistribution",
+ iExofct = "OptionalFunctionWithControl")
)
setClass("SSM",
representation = representation(initEq = "SSinitEq",
@@ -294,12 +294,12 @@
# in createF etc zurueckgegeben wird
setClass("SSretValueF",
representation = representation(x1 = "numeric",
- Fmat = "matrix",
- Rmat = "matrix",
+ FJcb = "matrix",
+ RJcb = "matrix",
t = "numeric",
x0 = "numeric",
v = "numeric",
- u = "numeric",
+ uNew = "numeric",
control = "OptionalList",
dots.propagated = "OptionalList",
call = "call",
@@ -307,12 +307,12 @@
)
setClass("SSretValueZ",
representation = representation(y = "numeric",
- Zmat = "matrix",
- Tmat = "matrix",
+ ZJcb = "matrix",
+ TJcb = "matrix",
t = "numeric",
x1 = "numeric",
eps = "numeric",
- w = "numeric",
+ wNew = "numeric",
control = "OptionalList",
dots.propagated = "OptionalList",
call = "call",
@@ -322,7 +322,6 @@
representation = representation(Q = "matrix",
t = "numeric",
x0 = "numeric",
- exQ = "ANY",
control = "OptionalList",
dots.propagated = "OptionalList",
call = "call",
@@ -332,7 +331,6 @@
representation = representation(V = "matrix",
t = "numeric",
x1 = "numeric",
- exV = "ANY",
control = "OptionalList",
dots.propagated = "OptionalList",
call = "call",
Added: branches/robKalman_2012/pkg/robKalman/R/uExomethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/uExomethods.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/uExomethods.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -0,0 +1,75 @@
+### constant, vector
+setMethod("createuExo", "vector", function (object)
+{
+## u ... vector, constant value of exogenous variable 'u'
+ u <- object
+
+ funcU <- function (t, x0, uOld = NULL, wNew = NULL)
+ {
+ ## t ... time index
+ ## x0 ... filter estimate x_{t-1|t-1}, vector
+ ## uOld ... exogenous variable u_{t-1}, vector!
+ ## wNew ... exogenous variable w_{t-1}, vector!
+
+ if (length(u) < length(x0)) {
+ u <- rep(u, length.out=length(x0))
+ }
+
+ if (length(u) > length(x0)) {
+ stop("Dimensions do not match!")
+ }
+
+ return(as.vector(u))
+
+ }
+ return(new("OptionalFunctionWithControl",funcU))
+})
+
+
+### time-discrete, matrix
+setMethod("createuExo", "matrix", function (object)
+{
+## u ... matrix, columnwise values of exogenous variable 'u'
+ u <- object
+
+ funcU <- function (t, x0, uOld = NULL, wNew = NULL)
+ {
+ ## t ... time index
+ ## x0 ... filter estimate x_{t-1|t-1}, vector
+ ## uOld ... exogenous variable u_{t-1}, vector!
+ ## wNew ... exogenous variable w_{t-1}, vector!
+
+ if (nrow(u) != length(x0)) {
+ stop("Dimensions do not match!")
+ }
+
+ return(as.vector(u[, t]))
+
+ }
+ return(new("OptionalFunctionWithControl",funcU))
+})
+
+
+### time-continuous, function
+setMethod("createuExo", "function", function (object)
+{
+## u ... function, u(t, x0, ...)
+ u <- object
+
+ funcU <- function (t, x0, uOld = NULL, wNew = NULL)
+ {
+ ## t ... time index
+ ## x0 ... filter estimate x_{t-1|t-1}, vector
+ ## uOld ... exogenous variable u_{t-1}, vector!
+ ## wNew ... exogenous variable w_{t-1}, vector!
+
+ retU <- as.vector(u(t, x0, uOld, wNew))
+
+ if (length(retU) != length(x0)) {
+ stop("Dimensions do not match!")
+ }
+
+ return(retU)
+ }
+ return(new("OptionalFunctionWithControl",funcU))
+})
Added: branches/robKalman_2012/pkg/robKalman/R/wExomethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/wExomethods.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/wExomethods.R 2013-04-06 18:11:06 UTC (rev 61)
@@ -0,0 +1,78 @@
+### constant, vector
+setMethod("createwExo", "vector", function (object)
+{
+## w ... vector, constant value of exogenous variable 'w'
+ w <- object
+
+ funcW <- function (t, x1, uNew = NULL, wOld = NULL)
+ {
+ ## t ... time index
+ ## x1 ... one-step ahead predictor x_{t|t-1}, vector
+ ## y ... observations y_t, 'global' variable!
+ ## uNew ... exogenous variable u_t, vector!
+ ## wOld ... exogenous variable w_{t-1}, vector!
+
+ if (length(w) < length(y)) {
+ w <- rep(w, length.out=length(y))
+ }
+
+ if (length(w) > length(y)) {
+ stop("Dimensions do not match!")
+ }
+
+ return(as.vector(w))
+
+ }
+ return(new("OptionalFunctionWithControl",funcW))
+})
+
+
+### time-discrete, matrix
+setMethod("createwExo", "matrix", function (object)
+{
+## w ... matrix, columnwise values of exogenous variable 'w'
+ w <- object
+
+ funcW <- function (t, x1, uNew = NULL, wOld = NULL)
+ {
+ ## t ... time index
+ ## x1 ... one-step ahead predictor x_{t|t-1}, vector
+ ## y ... observations y_t, 'global' variable!
+ ## uNew ... exogenous variable u_t, vector!
+ ## wOld ... exogenous variable w_{t-1}, vector!
+
+ if (nrow(w) != length(y)) {
+ stop("Dimensions do not match!")
+ }
+
+ return(as.vector(w[, t]))
+
+ }
+ return(new("OptionalFunctionWithControl",funcW))
+})
+
+
+### time-continuous, function
+setMethod("createwExo", "function", function (object)
+{
+## w ... function, w(t, x1, ...)
+ w <- object
+
+ funcW <- function (t, x1, uNew = NULL, wOld = NULL)
+ {
+ ## t ... time index
+ ## x1 ... one-step ahead predictor x_{t|t-1}, vector
+ ## y ... observations y_t, 'global' variable!
+ ## uNew ... exogenous variable u_t, vector!
+ ## wOld ... exogenous variable w_{t-1}, vector!
+
+ retW <- as.vector(w(t, x1, uNew, wOld))
+
+ if (length(retW) != length(y)) {
+ stop("Dimensions do not match!")
+ }
+
+ return(retW)
+ }
+ return(new("OptionalFunctionWithControl",funcW))
+})
More information about the Robkalman-commits
mailing list