[Robkalman-commits] r60 - branches/robKalman_2012/pkg/robKalman/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Apr 3 14:47:08 CEST 2013
Author: bspangl
Date: 2013-04-03 14:47:07 +0200 (Wed, 03 Apr 2013)
New Revision: 60
Modified:
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
Log:
update diverse robKalman-Funktionen
Modified: branches/robKalman_2012/pkg/robKalman/R/Fmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2013-03-06 09:21:08 UTC (rev 59)
+++ branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2013-04-03 12:47:07 UTC (rev 60)
@@ -44,7 +44,8 @@
}
if (is.null(R)) {
- R <- array(diag((dim(F))[1]), dim=dim(F))
+ nrowF <- dim(F)[1]
+ R <- array(diag(nrowF), dim=c(nrowF, nrowF, dim(F)[3]))
}
funcF <- function (t, x0, v, u, control, dots)
@@ -74,31 +75,29 @@
### function case
setMethod("createF", "function", function (object)
{
-## F ... array of state equation, F[, , t]
-## R ... selection matrix array (cf. Durbin & Koopman, 2001, p.38)
+## F ... function, F(t, x0, v, u, control, dots)
F <- object
-# ### some F checking possible and needed
-#
-#
-# funcF <- function (t, x0, v, u, control, dots)
-# {
-# ## t ... time index
-# ## x0 ... filter estimate x_{t-1|t-1}, vector
-# ## v ... innovations v_t, vector!
-# ## u ... exogenous variable u_{t-1}, vector!
-# ## control ... control parameters, list
-# ## dots ... additional parameters, list
-# call <- match.call()
-#
-# ret0 <- F(t, x0, v, u, control, dots)
-# if(is(ret0,"SSretValueF")) return(ret0)
-#
-# retF <- new("SSretValueF", x1 = ret0$x1, F = ret0$F,
-# R = NULL, t=t, x0=x0, control=control,
-# dots = dots, call = call, diagnostics = list())
-# return(retF)
-# }
- return(new("FunctionWithControl",F))
-# return(new("FunctionWithControl",funcF))
+ funcF <- function (t, x0, v, u, control, dots)
+ {
+ ## t ... time index
+ ## x0 ... filter estimate x_{t-1|t-1}, vector
+ ## v ... innovations v_t, vector!
+ ## u ... exogenous variable u_{t-1}, vector!
+ ## control ... control parameters, list
+ ## dots ... additional parameters, list
+ call <- match.call()
+
+ ret0 <- F(t, x0, v, u, 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,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
+ return(retF)
+ }
+ return(new("FunctionWithControl",funcF))
})
Modified: branches/robKalman_2012/pkg/robKalman/R/Qmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2013-03-06 09:21:08 UTC (rev 59)
+++ branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2013-04-03 12:47:07 UTC (rev 60)
@@ -29,7 +29,6 @@
setMethod("createQ", "array", function (object)
{
## Q ... array of covariance matrices of innovations, Q[, , t]
-
Q <- object
funcQ <- function (t, x0, exQ, control, dots)
@@ -41,18 +40,14 @@
## dots ... additional parameters, list
call <- match.call()
-
- retQ <- new("SSretValueQ", Q = Q[,,t,drop=TRUE], t=t,
- x0 = x0, exQ = exQ,
- control=control, dots = dots, call = call,
- diagnostics = list())
-
-
+ retQ <- new("SSretValueQ",
+ Q = Q[, , t, drop=TRUE], t = t,
+ x0 = x0, exQ = exQ, 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-03-06 09:21:08 UTC (rev 59)
+++ branches/robKalman_2012/pkg/robKalman/R/StepFunct.R 2013-04-03 12:47:07 UTC (rev 60)
@@ -19,7 +19,7 @@
## returns: x0, S0, controlInit
## control ... control argument of step function
- initS <- function (initEq, controlInit=control, ...)
+ fctInitS <- function (initEq, controlInit=control, ...)
{
## initEq ... object of S4 class 'SSinitEq'
## controlInit ... control parameters, list
@@ -40,7 +40,7 @@
diagnostics = list())
return(SSInitialized)
}
- return(new("FunctionWithControl", initS))
+ return(new("FunctionWithControl", fctInitS))
}
## CreatePrep <- still TBD!
@@ -51,11 +51,16 @@
## arguments: x0, S0, F, Q, i, v, u,
## controlF, exQ, controlQ,
## controlPred, dots-arg
+ ## uOld (unveraendert vom Input 'Corr-Step'),
+ ## wNew (Auswertung von 'wExofct' im 'Corr-Step')
+ ## Aktion: in 'F' Aufruf von 'uExofct' u.a. mit 'uOld' und 'wNew'!!!
## returns: x1, S1, controlPred
+ ## uNew (Auswertung von 'uExofct' im 'Pred-Step'),
+ ## wOld (unveraendert vom Input 'Pred-Step')
## control ... control argument of step function
- predS.fct <- function (i, PredOrFilt, statesEq, controlPred=control,
- whenEvalExo =c("pre"=TRUE,post="TRUE"), ...)
+ fctPredS <- function (i, PredOrFilt, statesEq, controlPred=control,
+ whenEvalExo =c("pre"=TRUE, "post"=FALSE), ...)
{
## i ... time index
## PredOrFilt ... object of S4 class 'SSPredOrFilt'
@@ -68,11 +73,16 @@
S0 <- PredOrFilt at variance
F <- statesEq at Ffct
Q <- statesEq at Qfct
- v <- # ???
- u <- # ???
- controlF <- # ???
- exQ <- # ???
- controlQ <- # ???
+ v <- # ??? -> wird hart kodiert als default in 'F'!
+ u <- # ??? -> 'uExofct'
+ controlF <- # ??? -> Fall (b)
+ ## Stand 2013-02-14: 'control*' kommt in zwei Varianten:
+ ## (a) rekursiv uebergebene Variante -> Rueckgabewerte der
+ ## Step-Funktionen
+ ## (b) globale Kontrolle fuer Afgorithmus und von aussen
+ ## gegeben -> 'SSClassOrRobFilterOrSmoother'
+ exQ <- # ??? -> gestrichten!
+ controlQ <- # ??? -> Fall (b)
if(whenEvalExo["pre"]) u <- exofun(...)
@@ -92,7 +102,7 @@
diagnostics = list())
return(SSPredicted)
}
- return(new("FunctionWithControl", predS.fct))
+ return(new("FunctionWithControl", fctPredS))
}
CreateCorr <- function (corrS, control=list())
@@ -100,11 +110,16 @@
## corrS ... original correction step function handling S3 objects
## arguments: y, x1, S1, Z, V, i, eps, w,
## controlZ, exV, controlV,
- ## controlCorr, dots-arg
- ## returns: x0, K, S0, Delta, DeltaY, controlCorr
+ ## controlCorr, dots-arg,
+ ## uNew (Auswertung von 'uExofct' im 'Pred-Step'),
+ ## wOld (unveraendert vom Input 'Pred-Step')
+ ## Aktion: in 'Z' Aufruf von 'wExofct' u.a. mit 'uNew' und 'wOld'!!!
+ ## returns: x0, K, S0, Delta, DeltaY, controlCorr,
+ ## uOld (unveraendert vom Input 'Corr-Step'),
+ ## wNew (Auswertung von 'wExofct' im 'Corr-Step')
## control ... control argument of step function
- corrS <- function (i, PredOrFilt, obsEq, controlCorr=control, ...)
+ fctCorrS <- function (i, PredOrFilt, obsEq, controlCorr=control, ...)
{
## i ... time index
## Obs ... object of S4 class 'SSObs'
@@ -142,5 +157,5 @@
DeltaY = retCorrS$DeltaY)
return(SSFiltered)
}
- return(new("FunctionWithControl", PredS))
+ return(new("FunctionWithControl", fctCorrS))
}
Modified: branches/robKalman_2012/pkg/robKalman/R/Vmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2013-03-06 09:21:08 UTC (rev 59)
+++ branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2013-04-03 12:47:07 UTC (rev 60)
@@ -29,7 +29,6 @@
setMethod("createV", "array", function (object)
{
## V ... array of covariance matrices of innovations, V[, , t]
-
V <- object
funcV <- function(t, x1, exV, control, dots)
@@ -41,18 +40,14 @@
## dots ... additional parameters, list
call <- match.call()
-
- retV <- new("SSretValueV", V = V[,,t,drop=TRUE], t=t,
- x1 = x1, exV = exV,
- control=control, dots = dots, call = call,
- diagnostics = list())
-
-
+ retV <- new("SSretValueV",
+ V = V[, , t, drop=TRUE], t = t,
+ x1 = x1, exV = exV, 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-03-06 09:21:08 UTC (rev 59)
+++ branches/robKalman_2012/pkg/robKalman/R/Zmethods.R 2013-04-03 12:47:07 UTC (rev 60)
@@ -39,10 +39,13 @@
## T ... selection matrix array (observation noise)
Z <- object
- if(length(dim(Z))==2) return(getMethod("Z", "matrix")(as.matrix(object),T))
+ if (length(dim(Z))==2) {
+ return(getMethod("Z", "matrix")(as.matrix(object), T))
+ }
if (is.null(T)) {
- T <- array(diag((dim(Z))[1]), dim=dim(Z))
+ nrowZ <- dim(Z)[1]
+ T <- array(diag(nrowZ), dim=c(nrowZ, nrowZ, dim(Z)[3]))
}
funcZ <- function (t, x1, eps, w, control, dots)
@@ -57,13 +60,13 @@
y <- Z[, , t]%*%x1 + w + T[, , t]%*%eps
- retZ <- new("SSretValueZ", y = y, Z = Z[,,t,drop=TRUE],
- T = T[,,t,drop=TRUE], t=t, x1 = x1, eps = eps, w = w,
- control=control, dots = dots, call = call,
- diagnostics = list())
+ 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,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retZ)
}
-
return(new("FunctionWithControl",funcZ))
})
More information about the Robkalman-commits
mailing list