[Robkalman-commits] r63 - branches/robKalman_2012/pkg/robKalman/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Apr 19 15:03:08 CEST 2013
Author: bspangl
Date: 2013-04-19 15:03:08 +0200 (Fri, 19 Apr 2013)
New Revision: 63
Modified:
branches/robKalman_2012/pkg/robKalman/R/classEKF4.R
branches/robKalman_2012/pkg/robKalman/R/uExomethods.R
branches/robKalman_2012/pkg/robKalman/R/wExomethods.R
Log:
diverse Updates
Modified: branches/robKalman_2012/pkg/robKalman/R/classEKF4.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/classEKF4.R 2013-04-08 04:35:58 UTC (rev 62)
+++ branches/robKalman_2012/pkg/robKalman/R/classEKF4.R 2013-04-19 13:03:08 UTC (rev 63)
@@ -32,7 +32,28 @@
A %*% S0 %*% t(A) + B %*% Q %*% t(B)
}
+cEKFinitS <- function (initEq,
+ controlInit = NULL, ...)
+{
+ ## initEq ... object of S4 class 'SSinitEq'
+ ## controlInit ... control parameters, list
+ call <- match.call()
+ dots.propagated <- list(...)
+ x0 <- initEq at a0
+ S0 <- initEq at Sigma0
+
+ SSInitialized <- new("SSInitialized",
+ values = x0,
+ call = call,
+ variance = S0,
+ uExo = NULL,
+ wExo = NULL,
+ dots.propagated = dots.propagated,
+ control = controlInit,
+ diagnostics = new("SSDiagnosticFilter"))
+ return(SSInitialized)
+}
cEKFpredS <- function (t,
PredOrFilt,
@@ -46,16 +67,93 @@
call <- match.call()
dots.propagated <- list(...)
-
+ x0 <- PredOrFilt at values
+ S0 <- PredOrFilt at variance
+ uExo <- PredOrFilt at uExo
+ wExo <- PredOrFilt at wExo
+ Ffct <- stateEq at Ffct
+ Qfct <- stateEq at Qfct
+ uExofct <- stateEq at uExofct
+ if (is.null(uExofct)) uExofct <- createuExo(0)
+ Freturn <- Ffct(t=t, x0=x0,
+ uFct=uExofct, uOld=uExo, wNew=wExo)
+ x1 <- Freturn at x1
+ A <- Freturn at FJcb
+ B <- Freturn at RJcb
+ uNew <- Freturn at uNew
+
+ Qreturn <- Qfct(t=t, x0=x0)
+ Q <- Qreturn at Q
+
+ S1 <- .getpredCov(S0=S0, A=A, B=B, Q=Q)
+
SSPredicted <- new("SSPredicted",
values = x1,
call = call,
variance = S1,
- uExo = ,
- wExo = wOld,
+ uExo = uNew,
+ wExo = wExo,
dots.propagated = dots.propagated,
control = controlPred,
diagnostics = new("SSDiagnosticFilter"))
return(SSPredicted)
}
+
+cEKFcorrS <- function (i, t,
+ Obs,
+ PredOrFilt,
+ obsEq,
+ controlCorr = NULL, ...)
+{
+ ## i ... loop index
+ ## t ... time, t[i]
+ ## Obs ... object of S4 class 'SSObs'
+ ## PredOrFilt ... object of S4 class 'SSPredOrFilt'
+ ## obsEq ... object of S4 class 'SSobsEq'
+ ## controlCorr ... control parameters, list
+ call <- match.call()
+ dots.propagated <- list(...)
+
+ y <- Obs at Y[, i]
+ x1 <- PredOrFilt at values
+ S1 <- PredOrFilt at variance
+ uExo <- PredOrFilt at uExo
+ wExo <- PredOrFilt at wExo
+ Zfct <- obsEq at Zfct
+ Vfct <- obsEq at Vfct
+ wExofct <- obsEq at wExofct
+ if (is.null(wExofct)) wExofct <- createwExo(0)
+
+ Zreturn <- Zfct(t=t, x1=x1,
+ wFct=wExofct, uNew=uExo, wOld=wExo)
+ yhat <- Zreturn at y
+ C <- Zreturn at ZJcb
+ D <- Zreturn at TJcb
+ wNew <- Zreturn at wNew
+
+ Vreturn <- Vfct(t=t, x1=x1)
+ V <- Vreturn at V
+
+ Delta <- .getDelta(S1=S1, C=C, D=D, V=V)
+ K <- .getKG(S1=S1, Z=C, Delta=Delta)
+ DeltaY <- y - yhat
+
+ x0 <- x1 + K %*% DeltaY
+ S0 <- .getcorrCov(S1=S1, K=K, Z=C)
+
+ SSFiltered <- new("SSFiltered",
+ values = x0,
+ call = call,
+ variance = S0,
+ uExo = uExo,
+ wExo = wNew,
+ KalmanGain = K,
+ CovObs = Delta,
+ DeltaY = DeltaY,
+ dots.propagated = dots.propagated,
+ control = controlCorr,
+ diagnostics = new("SSDiagnosticFilter"))
+ return(SSFiltered)
+}
+
Modified: branches/robKalman_2012/pkg/robKalman/R/uExomethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/uExomethods.R 2013-04-08 04:35:58 UTC (rev 62)
+++ branches/robKalman_2012/pkg/robKalman/R/uExomethods.R 2013-04-19 13:03:08 UTC (rev 63)
@@ -1,12 +1,13 @@
### constant, vector
-setMethod("createuExo", "vector", function (object)
+setMethod("createuExo", "numeric", function (object)
{
## u ... vector, constant value of exogenous variable 'u'
u <- object
- funcU <- function (t, x0, uOld = NULL, wNew = NULL)
+ funcU <- function (i, t, x0, uOld = NULL, wNew = NULL)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x0 ... filter estimate x_{t-1|t-1}, vector
## uOld ... exogenous variable u_{t-1}, vector!
## wNew ... exogenous variable w_{t-1}, vector!
@@ -32,9 +33,10 @@
## u ... matrix, columnwise values of exogenous variable 'u'
u <- object
- funcU <- function (t, x0, uOld = NULL, wNew = NULL)
+ funcU <- function (i, t, x0, uOld = NULL, wNew = NULL)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## x0 ... filter estimate x_{t-1|t-1}, vector
## uOld ... exogenous variable u_{t-1}, vector!
## wNew ... exogenous variable w_{t-1}, vector!
@@ -43,7 +45,7 @@
stop("Dimensions do not match!")
}
- return(as.vector(u[, t]))
+ return(as.vector(u[, i]))
}
return(new("OptionalFunctionWithControl",funcU))
@@ -56,14 +58,15 @@
## u ... function, u(t, x0, ...)
u <- object
- funcU <- function (t, x0, uOld = NULL, wNew = NULL)
+ funcU <- function (i=NULL, t, x0, uOld = NULL, wNew = NULL)
{
- ## t ... time index
+ ## i ... loop index
+ ## t ... time, t[i]
## 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))
+ retU <- as.vector(u(i=i, t=t, x0=x0, uOld=uOld, wNew=wNew))
if (length(retU) != length(x0)) {
stop("Dimensions do not match!")
Modified: branches/robKalman_2012/pkg/robKalman/R/wExomethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/wExomethods.R 2013-04-08 04:35:58 UTC (rev 62)
+++ branches/robKalman_2012/pkg/robKalman/R/wExomethods.R 2013-04-19 13:03:08 UTC (rev 63)
@@ -1,14 +1,15 @@
### constant, vector
-setMethod("createwExo", "vector", function (object)
+setMethod("createwExo", "numeric", function (object)
{
## w ... vector, constant value of exogenous variable 'w'
w <- object
- funcW <- function (t, x1, uNew = NULL, wOld = NULL)
+ funcW <- function (i, t, x1, y, uNew = NULL, wOld = 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, 'global' variable!
+ ## y ... observations y_t
## uNew ... exogenous variable u_t, vector!
## wOld ... exogenous variable w_{t-1}, vector!
@@ -33,11 +34,12 @@
## w ... matrix, columnwise values of exogenous variable 'w'
w <- object
- funcW <- function (t, x1, uNew = NULL, wOld = NULL)
+ funcW <- function (i, t, x1, y, uNew = NULL, wOld = 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, 'global' variable!
+ ## y ... observations y_t
## uNew ... exogenous variable u_t, vector!
## wOld ... exogenous variable w_{t-1}, vector!
@@ -45,7 +47,7 @@
stop("Dimensions do not match!")
}
- return(as.vector(w[, t]))
+ return(as.vector(w[, i]))
}
return(new("OptionalFunctionWithControl",funcW))
@@ -55,18 +57,19 @@
### time-continuous, function
setMethod("createwExo", "function", function (object)
{
-## w ... function, w(t, x1, ...)
+## w ... function, w(t, x1, y, ...)
w <- object
- funcW <- function (t, x1, uNew = NULL, wOld = NULL)
+ funcW <- function (i=NULL, t, x1, y, uNew = NULL, wOld = 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, 'global' variable!
+ ## y ... observations y_t
## uNew ... exogenous variable u_t, vector!
## wOld ... exogenous variable w_{t-1}, vector!
- retW <- as.vector(w(t, x1, uNew, wOld))
+ retW <- as.vector(w(i=i, t=t, x1=x1, y=y, uNew=uNew, wOld=wOld))
if (length(retW) != length(y)) {
stop("Dimensions do not match!")
More information about the Robkalman-commits
mailing list