[Robkalman-commits] r44 - in branches/robKalman_2012/pkg/robKalman: . R R/toDoP
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Jun 25 20:05:21 CEST 2012
Author: ruckdeschel
Date: 2012-06-25 20:05:20 +0200 (Mon, 25 Jun 2012)
New Revision: 44
Added:
branches/robKalman_2012/pkg/robKalman/R/AllGenerics.R
branches/robKalman_2012/pkg/robKalman/R/Exomethods.R
branches/robKalman_2012/pkg/robKalman/R/Fmethods.R
branches/robKalman_2012/pkg/robKalman/R/Qmethods.R
branches/robKalman_2012/pkg/robKalman/R/SSM-classes.R
branches/robKalman_2012/pkg/robKalman/R/Vmethods.R
branches/robKalman_2012/pkg/robKalman/R/Zmethods.R
Removed:
branches/robKalman_2012/pkg/robKalman/R/pkgAlt/
branches/robKalman_2012/pkg/robKalman/R/toDoP/0AllClass.R
branches/robKalman_2012/pkg/robKalman/R/toDoP/AllGenerics.R
branches/robKalman_2012/pkg/robKalman/R/toDoP/AllInitialize.R
branches/robKalman_2012/pkg/robKalman/R/toDoP/allClass.R
branches/robKalman_2012/pkg/robKalman/R/toDoP/allClasses.R
branches/robKalman_2012/pkg/robKalman/R/toDoP/allGenerics (2).R
Modified:
branches/robKalman_2012/pkg/robKalman/DESCRIPTION
branches/robKalman_2012/pkg/robKalman/NAMESPACE
branches/robKalman_2012/pkg/robKalman/R/allClass.R
Log:
an S4 Klassen f?\195?\188r SSM gearbeitet
Modified: branches/robKalman_2012/pkg/robKalman/DESCRIPTION
===================================================================
--- branches/robKalman_2012/pkg/robKalman/DESCRIPTION 2012-06-15 15:19:26 UTC (rev 43)
+++ branches/robKalman_2012/pkg/robKalman/DESCRIPTION 2012-06-25 18:05:20 UTC (rev 44)
@@ -1,11 +1,11 @@
Package: robKalman
Version: 1.0
-Date: 2011-08-14
+Date: 2012-06-27
Title: Robust Kalman Filtering
Description: Routines for Robust Kalman Filtering --- the ACM- and rLS-filter
Author: Peter Ruckdeschel, Bernhard Spangl
Maintainer: Peter Ruckdeschel <Peter.Ruckdeschel at itwm.fraunhofer.de>
-Depends: R(>= 2.3.0), methods, graphics, startupmsg, MASS, robustbase, numDeriv, robust-ts
+Depends: R(>= 2.3.0), methods, graphics, startupmsg, MASS, robustbase, numDeriv, robust-ts, distr, distrEx, distrEllipse
Imports: stats, MASS
LazyLoad: yes
License: LGPL-3
Modified: branches/robKalman_2012/pkg/robKalman/NAMESPACE
===================================================================
--- branches/robKalman_2012/pkg/robKalman/NAMESPACE 2012-06-15 15:19:26 UTC (rev 43)
+++ branches/robKalman_2012/pkg/robKalman/NAMESPACE 2012-06-25 18:05:20 UTC (rev 44)
@@ -2,6 +2,9 @@
import("stats")
import("MASS")
import("startupmsg")
+import("distr")
+import("distrEx")
+import("distrEllipse")
import("robustbase")
import("numDeriv")
import("robust-ts")
@@ -11,3 +14,31 @@
"rLScalibrateB", "limitS", "rLSFilter", "rLS.IO.Filter",
"rLS.AO.Filter", "KalmanFilter",
"recursiveFilter")
+
+
+
+
+exportClasses("OptionalList","OptionalFunctionWithControl",
+ "FunctionWithControl","SSTransform", "SSVar", "SSTransform",
+ "SSExo", "SSstateEq", "SSinitEq", "SSobsEq", "SSM",
+ "SStimes", "SSObs", "SSFilter", "SSrobFilter", "SSSmoother",
+ "SSrobSmoother", "SSClassOrRobFilter", "SSClassOrRobSmoother",
+ "SSClassOrRobSmootherOrFilter","SSDiagnostic","SSDiagnosticFilter",
+ "SSVariances", "SSStateReconstr", "SSPredOrFilt", "SSPredicted",
+ "SSFiltered", "SSSmoothed", "OptionalSSPredicted", "OptionalSSFiltered",
+ "OptionalSSSmoothed","SSInput","SSOutput","SSrecResult", "OptionalDistribution"
+ "SSISimulation", "SSCSimulation", "SSSimulation",
+ "SSSimList", "SSContSimulation",
+ "SSretValueF", "SSretValueZ", "SSretValueQ", "SSretValueV")
+
+exportMethods("solve", "name", "fct", "dots", "control", "F", "Z", "Q", "V", "T", "R", "t", "Exo",
+ "distr", "a0", "Sigma0", "times", "inX", "origData",
+ "initEq", "statesEq", "obsEq", "initStep", "predStep", "corrStep",
+ "classFilter", "robFilter", "filt", "smoothStep", "smoothCov", "lagoneCov",
+ "classSmoother", "robFilter", "robSmoother", "diagnostics" , "values",
+ "variances", "KalmanGain", "CovObs", "DeltaY", "steps", "model", "obs",
+ "states", "times", "pred.cl", "filt.cl", "smooth.cl", "pred.rob", "filt.rob",
+ "smooth.rob", "input", "output", "runs", "seed", "radius", "SimList",
+ "x0", "x1", "v", "u", "eps", "w", "exQ", "exV", "createF", "createZ", "createQ",
+ "createV", "createExo")
+
Added: branches/robKalman_2012/pkg/robKalman/R/AllGenerics.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/AllGenerics.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/AllGenerics.R 2012-06-25 18:05:20 UTC (rev 44)
@@ -0,0 +1,201 @@
+if(!isGeneric("solve")){
+ setGeneric("solve", function(a,b,...) standardGeneric("solve"))
+}
+############################################################################
+# Access methods
+############################################################################
+
+if(!isGeneric("name"))
+ setGeneric("name", function(object) standardGeneric("name"))
+
+if(!isGeneric("fct"))
+ setGeneric("fct", function(object) standardGeneric("fct"))
+
+if(!isGeneric("dots"))
+ setGeneric("dots", function(object) standardGeneric("dots"))
+
+if(!isGeneric("control"))
+ setGeneric("control", function(object) standardGeneric("control"))
+
+if(!isGeneric("F"))
+ setGeneric("F", function(object, ...) standardGeneric("F"))
+if(!isGeneric("Z"))
+ setGeneric("Z", function(object, ...) standardGeneric("Z"))
+if(!isGeneric("Q"))
+ setGeneric("Q", function(object, ...) standardGeneric("Q"))
+if(!isGeneric("V"))
+ setGeneric("V", function(object, ...) standardGeneric("V"))
+if(!isGeneric("createF"))
+ setGeneric("createF", function(object, ...) standardGeneric("createF"))
+if(!isGeneric("createZ"))
+ setGeneric("createZ", function(object, ...) standardGeneric("createZ"))
+if(!isGeneric("createQ"))
+ setGeneric("createQ", function(object, ...) standardGeneric("createQ"))
+if(!isGeneric("createV"))
+ setGeneric("createV", function(object, ...) standardGeneric("createV"))
+if(!isGeneric("createExo"))
+ setGeneric("createExo", function(object, ...) standardGeneric("createExo"))
+if(!isGeneric("R"))
+ setGeneric("R", function(object, ...) standardGeneric("R"))
+if(!isGeneric("t"))
+ setGeneric("t", function(object, ...) standardGeneric("t"))
+if(!isGeneric("T"))
+ setGeneric("T", function(object, ...) standardGeneric("T"))
+if(!isGeneric("Exo"))
+ setGeneric("Exo", function(object, ...) standardGeneric("Exo"))
+if(!isGeneric("distr"))
+ setGeneric("distr", function(object) standardGeneric("distr"))
+if(!isGeneric("Exo.states"))
+ setGeneric("Exo.states", function(object, ...) standardGeneric("Exo.states"))
+if(!isGeneric("Exo.init"))
+ setGeneric("Exo.init", function(object, ...) standardGeneric("Exo.init"))
+if(!isGeneric("Exo.obs"))
+ setGeneric("Exo.obs", function(object, ...) standardGeneric("Exo.obs"))
+if(!isGeneric("distr.states"))
+ setGeneric("distr.states", function(object, ...) standardGeneric("distr.states"))
+if(!isGeneric("distr.init"))
+ setGeneric("distr.init", function(object, ...) standardGeneric("distr.init"))
+if(!isGeneric("distr.obs"))
+ setGeneric("distr.obs", function(object, ...) standardGeneric("distr.obs"))
+
+if(!isGeneric("a0"))
+ setGeneric("a0", function(object) standardGeneric("a0"))
+if(!isGeneric("Sigma0"))
+ setGeneric("Sigma0", function(object) standardGeneric("Sigma0"))
+if(!isGeneric("times"))
+ setGeneric("times", function(x,...) standardGeneric("times"))
+if(!isGeneric("inX"))
+ setGeneric("inX", function(object) standardGeneric("inX"))
+
+if(!isGeneric("origData"))
+ setGeneric("origData", function(object) standardGeneric("origData"))
+
+if(!isGeneric("initEq"))
+ setGeneric("initEq", function(object) standardGeneric("initEq"))
+if(!isGeneric("statesEq"))
+ setGeneric("statesEq", function(object) standardGeneric("statesEq"))
+if(!isGeneric("obsEq"))
+ setGeneric("obsEq", function(object) standardGeneric("obsEq"))
+
+if(!isGeneric("initStep"))
+ setGeneric("initStep", function(object) standardGeneric("initStep"))
+if(!isGeneric("predStep"))
+ setGeneric("predStep", function(object) standardGeneric("predStep"))
+if(!isGeneric("prepStep"))
+ setGeneric("prepStep", function(object) standardGeneric("prepStep"))
+if(!isGeneric("corrStep"))
+ setGeneric("corrStep", function(object) standardGeneric("corrStep"))
+
+if(!isGeneric("classFilter"))
+ setGeneric("classFilter", function(object) standardGeneric("classFilter"))
+if(!isGeneric("robFilter"))
+ setGeneric("robFilter", function(object) standardGeneric("robFilter"))
+
+if(!isGeneric("filt"))
+ setGeneric("filt", function(object) standardGeneric("filt"))
+if(!isGeneric("smoothStep"))
+ setGeneric("smoothStep", function(object) standardGeneric("smoothStep"))
+if(!isGeneric("smoothCov"))
+ setGeneric("smoothCov", function(object) standardGeneric("smoothCov"))
+if(!isGeneric("lagoneCov"))
+ setGeneric("lagoneCov", function(object) standardGeneric("lagoneCov"))
+if(!isGeneric("classSmoother"))
+ setGeneric("classSmoother", function(object) standardGeneric("classSmoother"))
+if(!isGeneric("robFilter"))
+ setGeneric("robSmoother", function(object) standardGeneric("robSmoother"))
+
+if(!isGeneric("diagnostics"))
+ setGeneric("diagnostics", function(object) standardGeneric("diagnostics"))
+if(!isGeneric("values"))
+ setGeneric("values", function(object) standardGeneric("values"))
+if(!isGeneric("variances"))
+ setGeneric("variances", function(object) standardGeneric("variances"))
+
+if(!isGeneric("KalmanGain"))
+ setGeneric("KalmanGain", function(object) standardGeneric("KalmanGain"))
+if(!isGeneric("CovObs"))
+ setGeneric("CovObs", function(object) standardGeneric("CovObs"))
+if(!isGeneric("DeltaY"))
+ setGeneric("DeltaY", function(object) standardGeneric("DeltaY"))
+
+if(!isGeneric("steps"))
+ setGeneric("steps", function(object) standardGeneric("steps"))
+if(!isGeneric("model"))
+ setGeneric("model", function(object) standardGeneric("model"))
+if(!isGeneric("obs"))
+ setGeneric("obs", function(object) standardGeneric("obs"))
+if(!isGeneric("states"))
+ setGeneric("state", function(object) standardGeneric("states"))
+if(!isGeneric("times"))
+ setGeneric("times", function(object) standardGeneric("times"))
+
+if(!isGeneric("pred.cl"))
+ setGeneric("pred.cl", function(object) standardGeneric("pred.cl"))
+if(!isGeneric("filt.cl"))
+ setGeneric("filt.cl", function(object) standardGeneric("filt.cl"))
+if(!isGeneric("smooth.cl"))
+ setGeneric("smooth.cl", function(object) standardGeneric("smooth.cl"))
+
+if(!isGeneric("pred.rob"))
+ setGeneric("pred.rob", function(object) standardGeneric("pred.rob"))
+if(!isGeneric("filt.rob"))
+ setGeneric("filt.rob", function(object) standardGeneric("filt.rob"))
+if(!isGeneric("smooth.rob"))
+ setGeneric("smooth.rob", function(object) standardGeneric("smooth.rob"))
+
+if(!isGeneric("input"))
+ setGeneric("input", function(object) standardGeneric("input"))
+if(!isGeneric("output"))
+ setGeneric("output", function(object) standardGeneric("output"))
+
+
+if(!isGeneric("runs"))
+ setGeneric("runs", function(object, ...) standardGeneric("runs"))
+if(!isGeneric("seed"))
+ setGeneric("seed", function(object) standardGeneric("seed"))
+
+if(!isGeneric("radius"))
+ setGeneric("radius", function(object) standardGeneric("radius"))
+
+if(!isGeneric("SimList"))
+ setGeneric("SimList", function(object) standardGeneric("SimList"))
+
+if(!isGeneric("x0"))
+ setGeneric("x0", function(object) standardGeneric("x0"))
+
+if(!isGeneric("x1"))
+ setGeneric("x1", function(object) standardGeneric("x1"))
+
+if(!isGeneric("v"))
+ setGeneric("v", function(object) standardGeneric("v"))
+
+if(!isGeneric("u"))
+ setGeneric("u", function(object) standardGeneric("u"))
+
+if(!isGeneric("eps"))
+ setGeneric("eps", function(object) standardGeneric("eps"))
+
+if(!isGeneric("w"))
+ setGeneric("w", function(object) standardGeneric("w"))
+
+if(!isGeneric("exQ"))
+ setGeneric("exQ", function(object) standardGeneric("exQ"))
+
+if(!isGeneric("exV"))
+ setGeneric("exV", function(object) standardGeneric("exV"))
+
+
+
+if(!isGeneric("simulate"))
+ setGeneric("simulate",
+ function(object, nsim=-1, seed=-1, ...)
+ standardGeneric("simulate"))
+
+if(!isGeneric(".make.project"))
+setGeneric(".make.project",function(object, ...) standardGeneric(".make.project"))
+
+if(!isGeneric("kalman"))
+setGeneric("kalman",function(smooth, ...) standardGeneric("kalman"))
+
+if(!isGeneric("kalmanRob"))
+setGeneric("kalmanRob",function(method, smooth, ...) standardGeneric("kalmanRob"))
Added: branches/robKalman_2012/pkg/robKalman/R/Exomethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Exomethods.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/Exomethods.R 2012-06-25 18:05:20 UTC (rev 44)
@@ -0,0 +1,55 @@
+setMethod("createExo", "array", function (object) # time-variant case, linear
+{
+## Exo ... array of observation matrices, Exo[, , t]
+## T ... selection matrix array (observation noise)
+ Exo <- object
+
+ funcExo <- function (t, y, control, dots)
+ {
+ ## t ... time index
+ ## y ... observation
+ ## control ... control parameters, list
+ ## dots ... additional parameters, list
+ return(Exo[,t])
+ }
+
+ return(new("FunctionWithControl",funcExo))
+}
+
+setMethod("createExo", "matrix", function (object) # time-invariant case, linear
+{
+## Exo ... observation matrix
+## T ... selection matrix (observation noise)
+ Exo <- object
+
+ funcExo <- function (t, x1, eps, w, control, dots)
+ {
+ ## t ... time index
+ ## y ... observation
+ ## control ... control parameters, list
+ ## dots ... additional parameters, list
+ return(Exo)
+ }
+
+ return(new("FunctionWithControl",funcExo))
+}
+
+setMethod("createExo", "function", function (object) # function case
+{
+## Exo ... observation matrix
+## T ... selection matrix (observation noise)
+ Exo <- object
+
+ ### some Exo checking possible and needed
+
+ funcExo <- function (t, x1, eps, w, control, dots)
+ {
+ ## t ... time index
+ ## y ... observation
+ ## control ... control parameters, list
+ ## dots ... additional parameters, list
+ return(Exo(t, y, control, dots))
+ }
+
+ return(new("FunctionWithControl",funcExo))
+}
Added: branches/robKalman_2012/pkg/robKalman/R/Fmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Fmethods.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2012-06-25 18:05:20 UTC (rev 44)
@@ -0,0 +1,90 @@
+setMethod("createF", "array", function (object, R = NULL) # time-variant case, linear
+{
+## F ... array of state equation, F[, , t]
+## R ... selection matrix array (cf. Durbin & Koopman, 2001, p.38)
+
+ F <- object
+
+ if(length(dim(F))==2) return(getMethod("F", "matrix")(as.matrix(object),R))
+
+ if (is.null(R)) {
+ R <- array(diag((dim(F))[1]), dim=dim(F))
+ }
+
+ 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()
+
+ x1 <- F[, , t]%*%x0 + u + R[, , t]%*%v
+
+ retF <- new("SSretValueF", x1 = x1, F = F[,,t,drop=TRUE],
+ R = R[,,t,drop=TRUE], t=t, x0=x0, control=control,
+ dots = dots, call = call, diagnostics = list())
+ return(retF)
+ }
+ return(new("FunctionWithControl",funcF))
+}
+
+setMethod("createF", "matrix", function (object, R = NULL) # time-variant case, linear
+{
+## F ... array of state equation, F[, , t]
+## R ... selection matrix array (cf. Durbin & Koopman, 2001, p.38)
+ F <- object
+
+ if (is.null(R)) {
+ R <- diag(nrow(F))
+ }
+
+ 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()
+
+ x1 <- F%*%x0 + u + R%*%v
+
+ retF <- new("SSretValueF", x1 = x1, F = F[,,t,drop=TRUE],
+ R = R[,,t,drop=TRUE], t=t, x0=x0, control=control,
+ dots = dots, call = call, diagnostics = list())
+ return(retF)
+ }
+ return(new("FunctionWithControl",funcF))
+}
+
+setMethod("createF", "function", function (object) # function case
+{
+## F ... array of state equation, F[, , t]
+## R ... selection matrix array (cf. Durbin & Koopman, 2001, p.38)
+ 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)
+
+ 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",funcF))
+}
Added: branches/robKalman_2012/pkg/robKalman/R/Qmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Qmethods.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2012-06-25 18:05:20 UTC (rev 44)
@@ -0,0 +1,85 @@
+setMethod("createQ", "array", function (object) # time-variant case, linear
+{
+## Q ... array of covariance matrices of innovations, Q[, , t]
+
+ Q <- object
+
+ funcQ <- function (t, x0, exQ, control, dots)
+ {
+ ## 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, dots = dots, call = call,
+ diagnostics = list())
+
+
+ return(retQ)
+ }
+
+ return(new("FunctionWithControl",funcQ))
+
+}
+
+setMethod("createQ", "matrix", function (object) # time-variant case, linear
+{
+## Q ... covariance matrix of innovations
+
+ Q <- object
+
+ funcQ <- function (t, x0, exQ, control, dots)
+ {
+ ## 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,
+ control=control, dots = dots, call = call,
+ diagnostics = list())
+
+ return(retQ)
+ }
+
+ return(new("FunctionWithControl",funcQ))
+
+}
+
+
+setMethod("createQ", "function", function (object) # time-variant case, linear
+{
+## Q ... covariance matrix of innovations
+
+ Q <- object
+
+ funcQ <- function (t, x0, exQ, control, dots)
+ {
+ ## 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)
+
+ retQ <- new("SSretValueQ", Q = ret0$Q, t=t,
+ x0 = x0, exQ = exQ,
+ control=control, dots = dots, call = call,
+ diagnostics = list())
+
+ return(retQ)
+ }
+
+ return(new("FunctionWithControl",funcQ))
+}
Added: branches/robKalman_2012/pkg/robKalman/R/SSM-classes.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/SSM-classes.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/SSM-classes.R 2012-06-25 18:05:20 UTC (rev 44)
@@ -0,0 +1,36 @@
+SSM <- function(F, Q, Exo.state = NULL, R = NULL, distr.state = NULL,
+ Z, V, Exo.obs = NULL, T = NULL, distr.obs = NULL,
+ a0, Sigma0, Exo.ini =NULL, distr.ini = NULL,
+ p, q){
+ Exo.state.ret <- if(!is.null(Exo.state)) createExo(Exo.state) else NULL
+ Exo.obs.ret <- if(!is.null(Exo.obs)) createExo(Exo.obs) else NULL
+ Exo.ini.ret <- if(!is.null(Exo.ini)) createExo(Exo.ini) else NULL
+
+ Fret <- createF(F,R, Exo.state.ret)
+ Zret <- createZ(Z,T, Exo.state.obs)
+ Qret <- createQ(Q)
+ Vret <- createV(V)
+
+ stateEq <- new("SSstateEq", F=Fret, Q=Qret, Exo = Exo.state.ret, distr = distr.state)
+ obsEq <- new("SSobsEq", Z=Zret, V=Vret, Exo = Exo.obs.ret, distr = distr.obs)
+ initEq <- new("SSinitEq", a0=a0, Sigma0=Sigma0, Exo = Exo.ini.ret, distr = distr.ini)
+
+ return(new("SSM",initEq = initEq, statesEq = stateEq, obsEq = obsEq, p = p, q = q)
+}
+
+setMethod("statesEq", "SSM", function(object) object at statesEq)
+setMethod("obsEq", "SSM", function(object) object at obsEq)
+setMethod("initEq", "SSM", function(object) object at initEq)
+
+setMethod("F", "SSstateEq", function(object) object at F)
+setMethod("F", "SSM", function(object) statesEq(object)@F)
+setMethod("Q", "SSstateEq", function(object) object at Q)
+setMethod("Q", "SSM", function(object) statesEq(object)@Q)
+setMethod("Z", "SSstateEq", function(object) object at Z)
+setMethod("Z", "SSM", function(object) obsEq(object)@Z)
+setMethod("V", "SSstateEq", function(object) object at V)
+setMethod("V", "SSM", function(object) obsEq(object)@V)
+setMethod("a0", "SSstateEq", function(object) object at a0)
+setMethod("a0", "SSM", function(object) initEq(object)@a0)
+setMethod("Sigma0", "SSinitEq", function(object) object at Sigma0)
+setMethod("Sigma0", "SSM", function(object) initEq(object)@Sigma0)
Added: branches/robKalman_2012/pkg/robKalman/R/Vmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Vmethods.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2012-06-25 18:05:20 UTC (rev 44)
@@ -0,0 +1,86 @@
+setMethod("createV", "array", function (object) # time-variant case, linear
+{
+## V ... array of covariance matrices of innovations, V[, , t]
+
+ V <- object
+
+ funcV <- function(t, x1, exV, control, dots)
+ {
+ ## 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, dots = dots, call = call,
+ diagnostics = list())
+
+
+ return(retV)
+ }
+
+ return(new("FunctionWithControl",funcV))
+
+}
+
+setMethod("createV", "matrix", function (object) # time-variant case, linear
+{
+## V ... covariance matrix of innovations
+
+ V <- object
+
+ funcV <- function(t, x1, exV, control, dots)
+ {
+ ## 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,
+ control=control, dots = dots, call = call,
+ diagnostics = list())
+
+ return(retV)
+ }
+
+ return(new("FunctionWithControl",funcV))
+
+}
+
+
+setMethod("createV", "function", function (object) # time-variant case, linear
+{
+## V ... covariance matrix of innovations
+
+ V <- object
+
+ funcV <- function(t, x1, exV, control, dots)
+ {
+ ## 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)
+
+ retV <- new("SSretValueV", V = ret0$V, t=t,
+ x1 = x1, exV = exV,
+ control=control, dots = dots, call = call,
+ diagnostics = list())
+
+ return(retV)
+ }
+
+ return(new("FunctionWithControl",funcV))
+
+}
Added: branches/robKalman_2012/pkg/robKalman/R/Zmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Zmethods.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/Zmethods.R 2012-06-25 18:05:20 UTC (rev 44)
@@ -0,0 +1,95 @@
+setMethod("createZ", "array", function (object, T = NULL) # time-variant case, linear
+{
+## Z ... array of observation matrices, Z[, , t]
+## T ... selection matrix array (observation noise)
+ Z <- object
+
+ 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))
+ }
+
+ funcZ <- function (t, x1, eps, w, control, dots)
+ {
+ ## 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!
+ ## control ... control parameters, list
+ ## dots ... additional parameters, list
+ call <- match.call()
+
+ 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())
+ return(retZ)
+ }
+
+ return(new("FunctionWithControl",funcZ))
+}
+
+setMethod("createZ", "matrix", function (object, T = NULL) # time-variant case, linear
+{
+## Z ... observation matrix
+## T ... selection matrix (observation noise)
+ Z <- object
+
+ if (is.null(T)) {
+ T <- diag(nrow(Z))
+ }
+
+ funcZ <- function (t, x1, eps, w, control, dots)
+ {
+ ## 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!
+ ## control ... control parameters, list
+ ## dots ... additional parameters, list
+ call <- match.call()
+
+ y <- Z%*%x1 + w + T%*%eps
+
+ retZ <- new("SSretValueZ", y = y, Z = Z,
+ T = T, t=t, x1 = x1, eps = eps, w = w,
+ control=control, dots = dots, call = call,
+ diagnostics = list())
+ return(retZ)
+ }
+
+ return(new("FunctionWithControl",funcZ))
+}
+
+setMethod("createZ", "function", function (object) # function case
+{
+## Z ... observation matrix
+## T ... selection matrix (observation noise)
+ Z <- object
+
+ ### some Z checking possible and needed
+
+ funcZ <- function (t, x1, eps, w, control, dots)
+ {
+ ## 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!
+ ## control ... control parameters, list
+ ## dots ... additional parameters, list
+ call <- match.call()
+
+ ret0 <- Z(t, x1, eps, w, control, dots)
+
+ 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())
+ return(retZ)
+ }
+
+ return(new("FunctionWithControl",funcZ))
+}
Modified: branches/robKalman_2012/pkg/robKalman/R/allClass.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/allClass.R 2012-06-15 15:19:26 UTC (rev 43)
+++ branches/robKalman_2012/pkg/robKalman/R/allClass.R 2012-06-25 18:05:20 UTC (rev 44)
@@ -22,26 +22,28 @@
setClassUnion("OptionalList",
c("list","NULL")
)
+setClassUnion("OptionalFunction",
+ c("function","NULL")
+ )
## Class: FunctionWithControl
-setClass("FunctionWithControl",
- representation = representation(fct = "function",
- dots = "OptionalList",
- control = "OptionalList",
- name = "character"),
- prototype = prototype(fct = function(x)x, dots = NULL, control = NULL,
- name = gettext("a function with control"))
- )
-setClass("SSVar", contains="FunctionWithControl")
-setClass("SSTransform", contains="FunctionWithControl")
-setClass("SSExo", contains="FunctionWithControl")
+setClass("FunctionWithControl", contains = "function")
+### in validity method check whether has args dots and control
+
+setClassUnion("OptionalFunctionWithControl",
+ c("FunctionWithControl","NULL")
+ )
+
+setClassUnion("OptionalDistribution",
+ c("Distribution","NULL")
+ )
+
setClass("SSstateEq",
- representation = representation(F = "SSTransform",
- Q = "SSVar",
- Exo = "SSVar",
- mu = "function",
- distr = "Distribution"),
+ representation = representation(F = "FunctionWithControl",
+ Q = "FunctionWithControl",
+ Exo = "OptionalFunctionWithControl",
+ distr = "OptionalDistribution"),
prototype = prototype(F = new("SSTransform",
fct=function(...)1, control = NULL,
name="state transition"),
@@ -50,16 +52,14 @@
name="state variance"),
Exo = new("SSExo",
fct=function(...)1, control = NULL,
- name="state Exogenous variable"),
- mu = function(...)0,
+ name="state Exogenous variable")
distr = Norm())
)
setClass("SSobsEq",
- representation = representation(Z = "SSTransform",
- V = "SSVar",
- Exo = "SSVar",
- mu = "function",
- distr = "Distribution"),
+ representation = representation(Z = "FunctionWithControl",
+ V = "FunctionWithControl",
+ Exo = "OptionalFunctionWithControl",
+ distr = "OptionalDistribution"),
prototype = prototype(Z = new("SSTransform",
fct=function(...)1, control = NULL,
name="state transition"),
@@ -68,27 +68,139 @@
name="state variance"),
Exo = new("SSExo",
fct=function(...)1, control = NULL,
- name="state Exogenous variable"),
- mu = function(...)0,
+ name="state Exogenous variable")
distr = Norm())
)
-setClass("SSstartEq",
+setClass("SSinitEq",
representation = representation(a0 = "numeric",
Sigma0 = "matrix",
- Exo = "SSVar",
- mu = "function",
- distr = "Distribution"),
+ Exo = "OptionalFunctionWithControl",
+ distr = "OptionalDistribution"),
prototype = prototype(a0 = 1,
Sigma0 = matrix(1,1,1),
Exo = new("SSExo",
fct=function(...)0, control = NULL,
name="state Exogenous variable"),
- mu = function(...)0,
distr = Norm())
)
-setClass("SSmod",
- representation = representation(StartEq = "SSstartEq",
- StatesEq = "SSstateEq",
- ObsEq = "SSobsEq")
+setClass("SSM",
+ representation = representation(initEq = "SSinitEq",
+ statesEq = "SSstateEq",
+ obsEq = "SSobsEq",
+ p = "numeric", q = "numeric"))
)
+setClass("SStimes", representation = representation(times = "numeric",
+ inX = "logical"))
+
+setClass("SSObs",
+ representation = representation(Y = "numeric",
+ origData = "ANY",
+ Exo = "SSVar",
+ mu = "function"),
+ prototype = prototype(Y = 1,
+ origData = 1,
+ Exo = new("SSExo",
+ fct=function(...)0, control = NULL,
+ name="state Exogenous variable"),
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robkalman -r 44
More information about the Robkalman-commits
mailing list