[Robkalman-commits] r56 - in branches/robKalman_2012/pkg/robKalman: R inst
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Tue Feb 12 18:08:32 CET 2013
Author: bspangl
Date: 2013-02-12 18:08:32 +0100 (Tue, 12 Feb 2013)
New Revision: 56
Added:
branches/robKalman_2012/pkg/robKalman/R/StepFunct.R
branches/robKalman_2012/pkg/robKalman/inst/exS4-classKF.R
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
branches/robKalman_2012/pkg/robKalman/R/allClass.R
Log:
diverse Aktualisierungen
Modified: branches/robKalman_2012/pkg/robKalman/R/Fmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2013-02-08 14:26:33 UTC (rev 55)
+++ branches/robKalman_2012/pkg/robKalman/R/Fmethods.R 2013-02-12 17:08:32 UTC (rev 56)
@@ -1,14 +1,12 @@
-setMethod("createF", "array", function (object, R = NULL) # time-variant case, linear
+### time-invariant case, linear
+setMethod("createF", "matrix", function (object, R = NULL)
{
-## F ... array of state equation, F[, , t]
-## R ... selection matrix array (cf. Durbin & Koopman, 2001, p.38)
-
+## F ... matrix of state equation
+## R ... selection matrix (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))
+ R <- diag(nrow(F))
}
funcF <- function (t, x0, v, u, control, dots)
@@ -21,24 +19,32 @@
## dots ... additional parameters, list
call <- match.call()
- x1 <- F[, , t]%*%x0 + u + R[, , t]%*%v
+ 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())
+ retF <- new("SSretValueF",
+ x1 = as.vector(x1), Fmat = F, Rmat = R,
+ t=t, x0=x0, v = v, u = u, control=control,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retF)
}
return(new("FunctionWithControl",funcF))
})
-setMethod("createF", "matrix", function (object, R = NULL) # time-variant case, linear
+
+### time-variant case, linear
+setMethod("createF", "array", function (object, R = NULL)
{
## 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("createF", "matrix")(as.matrix(object), R))
+ }
+
if (is.null(R)) {
- R <- diag(nrow(F))
+ R <- array(diag((dim(F))[1]), dim=dim(F))
}
funcF <- function (t, x0, v, u, control, dots)
@@ -51,17 +57,22 @@
## dots ... additional parameters, list
call <- match.call()
- x1 <- F%*%x0 + u + R%*%v
+ 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())
+ 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,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retF)
}
return(new("FunctionWithControl",funcF))
})
-setMethod("createF", "function", function (object) # function case
+
+### function case
+setMethod("createF", "function", function (object)
{
## F ... array of state equation, F[, , t]
## R ... selection matrix array (cf. Durbin & Koopman, 2001, p.38)
Modified: branches/robKalman_2012/pkg/robKalman/R/Qmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2013-02-08 14:26:33 UTC (rev 55)
+++ branches/robKalman_2012/pkg/robKalman/R/Qmethods.R 2013-02-12 17:08:32 UTC (rev 56)
@@ -1,7 +1,7 @@
-setMethod("createQ", "array", function (object) # time-variant case, linear
+### time-invariant case, linear
+setMethod("createQ", "matrix", function (object)
{
-## Q ... array of covariance matrices of innovations, Q[, , t]
-
+## Q ... covariance matrix of innovations
Q <- object
funcQ <- function (t, x0, exQ, control, dots)
@@ -13,23 +13,22 @@
## dots ... additional parameters, list
call <- match.call()
-
- retQ <- new("SSretValueQ", Q = Q[,,t,drop=TRUE], t=t,
+ retQ <- new("SSretValueQ",
+ Q = Q, t=t,
x0 = x0, exQ = exQ,
- control=control, dots = dots, call = call,
- diagnostics = list())
-
-
+ control = control,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retQ)
}
-
return(new("FunctionWithControl",funcQ))
-
})
-setMethod("createQ", "matrix", function (object) # time-variant case, linear
+
+### time-variant case, linear
+setMethod("createQ", "array", function (object)
{
-## Q ... covariance matrix of innovations
+## Q ... array of covariance matrices of innovations, Q[, , t]
Q <- object
@@ -43,11 +42,12 @@
call <- match.call()
- retQ <- new("SSretValueQ", Q = Q, t=t,
+ retQ <- new("SSretValueQ", Q = Q[,,t,drop=TRUE], t=t,
x0 = x0, exQ = exQ,
control=control, dots = dots, call = call,
diagnostics = list())
+
return(retQ)
}
@@ -56,7 +56,8 @@
})
-setMethod("createQ", "function", function (object) # time-variant case, linear
+### function case
+setMethod("createQ", "function", function (object)
{
## Q ... covariance matrix of innovations
Added: branches/robKalman_2012/pkg/robKalman/R/StepFunct.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/StepFunct.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/StepFunct.R 2013-02-12 17:08:32 UTC (rev 56)
@@ -0,0 +1,141 @@
+#######################################################
+##
+## file: StepFunct.R
+## functions to transform original initialization,
+## prediction and correction step functions handling
+## only S3 objects into initialization, prediction
+## and correction step functions that are able to
+## handle S4 oblects and will return the corresponding
+## S4 objects
+## author: Bernhard Spangl
+## version: 0.1 (changed: 2013-02-09, created: 2013-02-09)
+##
+#######################################################
+
+CreateInit <- function (initS, control=list())
+{
+ ## initS ... original initialization step function handling S3 objects
+ ## arguments: a, S, controlInit, dots-arg
+ ## returns: x0, S0, controlInit
+ ## control ... control argument of step function
+
+ initS <- function (initEq, controlInit=control, ...)
+ {
+ ## initEq ... object of S4 class 'SSinitEq'
+ ## controlInit ... control parameters, list
+ call <- match.call()
+ dots.propagated <- list(...)
+
+ a <- initEq at a0
+ S <- initEq at Sigma0
+
+ retInitS <- initS(a=a, S=S, controlInit=controlInit, ...)
+
+ SSInitialized <- new("SSInitialized",
+ values = retInitS$x0,
+ call = call,
+ variance = retInitS$S0,
+ dots.propagated = dots.propagated,
+ control = retInitS$controlInit,
+ diagnostics = list())
+ return(SSInitialized)
+ }
+ return(new("FunctionWithControl", initS))
+}
+
+## CreatePrep <- still TBD!
+
+CreatePred <- function (predS, control=list())
+{
+ ## predS ... original prediction step function handling S3 objects
+ ## arguments: x0, S0, F, Q, i, v, u,
+ ## controlF, exQ, controlQ,
+ ## controlPred, dots-arg
+ ## returns: x1, S1, controlPred
+ ## control ... control argument of step function
+
+ predS <- function (i, PredOrFilt, statesEq, controlPred=control, ...)
+ {
+ ## i ... time index
+ ## PredOrFilt ... object of S4 class 'SSPredOrFilt'
+ ## statesEq ... object of S4 class 'SSstatesEq'
+ ## controlPred ... control parameters, list
+ call <- match.call()
+ dots.propagated <- list(...)
+
+ x0 <- PredOrFilt at values
+ S0 <- PredOrFilt at variance
+ F <- statesEq at Ffct
+ Q <- statesEq at Qfct
+ v <- # ???
+ u <- # ???
+ controlF <- # ???
+ exQ <- # ???
+ controlQ <- # ???
+
+ retPredS <- predS(x0=x0, S0=S0, F=F, Q=Q, i=i,
+ v=v, u=u, controlF=controlF,
+ exQ=exQ, controlQ=controlQ,
+ controlPred=controlPred, ...)
+
+ SSPredicted <- new("SSPredicted",
+ values = retPredS$x1,
+ call = call,
+ variance = retPredS$S1,
+ dots.propagated = dots.propagated,
+ control = retInitS$controlPred,
+ diagnostics = list())
+ return(SSPredicted)
+ }
+ return(new("FunctionWithControl", predS))
+}
+
+CreateCorr <- function (corrS, control=list())
+{
+ ## 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
+ ## control ... control argument of step function
+
+ corrS <- function (i, PredOrFilt, obsEq, controlCorr=control, ...)
+ {
+ ## i ... time index
+ ## 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
+ x1 <- PredOrFilt at values
+ S1 <- PredOrFilt at variance
+ Z <- obsEq at Zfct
+ V <- obsEq at Vfct
+ eps <- # ???
+ w <- # ???
+ controlZ <- # ???
+ exV <- # ???
+ controlV <- # ???
+
+ retCorrS <- corrS(y=y, x1=x1, S1=S1, Z=Z, V=V, i=i,
+ eps=eps, w=w, controlZ=controlZ,
+ exV=exV, controlV=controlV,
+ controlCorr=controlCorr, ...)
+
+ SSFiltered <- new("SSFiltered",
+ values = retCorrS$x0,
+ call = call,
+ variance = retCorrS$S0,
+ dots.propagated = dots.propagated,
+ control = retCorrS$controlCorr,
+ diagnostics = list(),
+ KalmanGain = retCorrS$K,
+ CovObs = retCorrS$Delta,
+ DeltaY = retCorrS$DeltaY)
+ return(SSFiltered)
+ }
+ return(new("FunctionWithControl", PredS))
+}
Modified: branches/robKalman_2012/pkg/robKalman/R/Vmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2013-02-08 14:26:33 UTC (rev 55)
+++ branches/robKalman_2012/pkg/robKalman/R/Vmethods.R 2013-02-12 17:08:32 UTC (rev 56)
@@ -1,7 +1,7 @@
-setMethod("createV", "array", function (object) # time-variant case, linear
+### time-invariant case, linear
+setMethod("createV", "matrix", function (object)
{
-## V ... array of covariance matrices of innovations, V[, , t]
-
+## V ... covariance matrix of innovations
V <- object
funcV <- function(t, x1, exV, control, dots)
@@ -13,23 +13,22 @@
## dots ... additional parameters, list
call <- match.call()
-
- retV <- new("SSretValueV", V = V[,,t,drop=TRUE], t=t,
+ retV <- new("SSretValueV",
+ V = V, t=t,
x1 = x1, exV = exV,
- control=control, dots = dots, call = call,
- diagnostics = list())
-
-
+ control=control,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retV)
}
-
return(new("FunctionWithControl",funcV))
-
})
-setMethod("createV", "matrix", function (object) # time-variant case, linear
+
+### time-variant case, linear
+setMethod("createV", "array", function (object)
{
-## V ... covariance matrix of innovations
+## V ... array of covariance matrices of innovations, V[, , t]
V <- object
@@ -43,11 +42,12 @@
call <- match.call()
- retV <- new("SSretValueV", V = V, t=t,
+ retV <- new("SSretValueV", V = V[,,t,drop=TRUE], t=t,
x1 = x1, exV = exV,
control=control, dots = dots, call = call,
diagnostics = list())
+
return(retV)
}
@@ -56,7 +56,8 @@
})
-setMethod("createV", "function", function (object) # time-variant case, linear
+### function case
+setMethod("createV", "function", function (object)
{
## V ... covariance matrix of innovations
Modified: branches/robKalman_2012/pkg/robKalman/R/Zmethods.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/Zmethods.R 2013-02-08 14:26:33 UTC (rev 55)
+++ branches/robKalman_2012/pkg/robKalman/R/Zmethods.R 2013-02-12 17:08:32 UTC (rev 56)
@@ -1,13 +1,12 @@
-setMethod("createZ", "array", function (object, T = NULL) # time-variant case, linear
+### time-invariant case, linear
+setMethod("createZ", "matrix", function (object, T = NULL)
{
-## Z ... array of observation matrices, Z[, , t]
-## T ... selection matrix array (observation noise)
+## Z ... observation matrix
+## T ... selection matrix (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))
+ T <- diag(nrow(Z))
}
funcZ <- function (t, x1, eps, w, control, dots)
@@ -20,26 +19,30 @@
## dots ... additional parameters, list
call <- match.call()
- y <- Z[, , t]%*%x1 + w + T[, , t]%*%eps
+ y <- Z%*%x1 + w + 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 = as.vector(y), Zmat = Z,
+ Tmat = T, t=t, x1 = x1, eps = eps, w = w,
+ control=control,
+ dots.propagated = dots, call = call,
+ diagnostics = new("SSDiagnosticRetValue"))
return(retZ)
}
-
return(new("FunctionWithControl",funcZ))
})
-setMethod("createZ", "matrix", function (object, T = NULL) # time-variant case, linear
+
+### time-variant case, linear
+setMethod("createZ", "array", function (object, T = NULL)
{
-## Z ... observation matrix
-## T ... selection matrix (observation noise)
+## 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 <- diag(nrow(Z))
+ T <- array(diag((dim(Z))[1]), dim=dim(Z))
}
funcZ <- function (t, x1, eps, w, control, dots)
@@ -52,10 +55,10 @@
## dots ... additional parameters, list
call <- match.call()
- y <- Z%*%x1 + w + T%*%eps
+ y <- Z[, , t]%*%x1 + w + T[, , t]%*%eps
- retZ <- new("SSretValueZ", y = y, Z = Z,
- T = T, t=t, x1 = x1, eps = eps, w = w,
+ 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)
@@ -64,7 +67,9 @@
return(new("FunctionWithControl",funcZ))
})
-setMethod("createZ", "function", function (object) # function case
+
+### function case
+setMethod("createZ", "function", function (object)
{
## Z ... observation matrix
## T ... selection matrix (observation noise)
Modified: branches/robKalman_2012/pkg/robKalman/R/allClass.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/allClass.R 2013-02-08 14:26:33 UTC (rev 55)
+++ branches/robKalman_2012/pkg/robKalman/R/allClass.R 2013-02-12 17:08:32 UTC (rev 56)
@@ -23,9 +23,9 @@
setClassUnion("OptionalList",
c("list","NULL")
)
-setClassUnion("OptionalFunction",
- c("function","NULL")
- )
+## setClassUnion("OptionalFunction", # existiert bereits!
+## c("function","NULL")
+## )
setClassUnion("OptionalCall",
c("call","NULL")
)
@@ -34,8 +34,8 @@
all(sapply(object, function (u) is(u)=="call"))
}
)
-setClassUnion("OptionalListofCalls",
- c("ListofCalls","NULL")
+setClassUnion("OptionalListOfCalls",
+ c("ListOfCalls","NULL")
)
@@ -48,7 +48,8 @@
)
setClassUnion("OptionalDistribution",
- c("Distribution","NULL")
+## c("Distribution","NULL") # S4 class 'Distribution' missing!
+ c("NULL")
)
@@ -155,7 +156,7 @@
diagnostics = "SSDiagnosticFilter"),
contains = "VIRTUAL"
)
-setClass("SSInizialized",
+setClass("SSInitialized",
contains = "SSPredOrFilt"
)
setClass("SSPrepared",
@@ -237,7 +238,7 @@
representation = representation(model = "SSM",
obs = "SSObs",
times = "SStimes",
- steps = "SSClassOrRobSmootherOrFilter")
+ steps = "SSClassOrRobFilterOrSmoother")
)
setClass("SSOutput",
representation = representation(init.cl = "SSInitialized",
@@ -245,7 +246,7 @@
pred.cl = "SSPredictedRet",
filt.cl = "SSFilteredRet",
smooth.cl = "OptionalSSSmoothedRet",
- init.rob = "OptionalSSInitialzed",
+ init.rob = "OptionalSSInitialized",
pred.rob = "OptionalSSPredictedRet",
filt.rob = "OptionalSSFilteredRet",
smooth.rob = "OptionalSSSmoothedRet",
@@ -278,7 +279,7 @@
setClass("SSSimList",
contains = "list"
)
- # Liste von Simulationen Typprüfung nicht
+ # Liste von Simulationen Typpruefung nicht
# vorgesehen; Erzeugung in Generating Function, sodass alle Anforderungen
# "passen"
setClass("SSContSimulation",
@@ -288,9 +289,9 @@
### Itermediate return values
- # ACHTUNG: entgegen Darstellung am 18.09.12 _nicht_ Rückgabetyp
- # von createF createV,... sondern Rückgabetyp der Funktion, die
- # in createF etc zurückgegeben wird
+ # ACHTUNG: entgegen Darstellung am 18.09.12 _nicht_ Rueckgabetyp
+ # von createF createV,... sondern Rueckgabetyp der Funktion, die
+ # in createF etc zurueckgegeben wird
setClass("SSretValueF",
representation = representation(x1 = "numeric",
Fmat = "matrix",
Added: branches/robKalman_2012/pkg/robKalman/inst/exS4-classKF.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/inst/exS4-classKF.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/inst/exS4-classKF.R 2013-02-12 17:08:32 UTC (rev 56)
@@ -0,0 +1,91 @@
+#######################################################
+##
+## file: exS4-classKF.R
+## classical Kalman filter example using only S4 classes
+## (cf. 'exampleLinearEKF.R')
+## author: Bernhard Spangl
+## version: 0.1 (changed: 2013-02-10, created: 2013-02-10)
+##
+#######################################################
+
+## for testing:
+path <- "~/university/svn/itwm/robKalman/"
+load(paste(path,
+ "Paper/StatisticsPaper/R-Code/bernhard/exampleLinearEKF_sp.RData",
+ sep=""))
+
+source("allClass.R")
+setGeneric("createF",
+ function(object, ...) standardGeneric("createF"))
+setGeneric("createZ",
+ function(object, ...) standardGeneric("createZ"))
+setGeneric("createQ",
+ function(object, ...) standardGeneric("createQ"))
+setGeneric("createV",
+ function(object, ...) standardGeneric("createV"))
+source("Fmethods.R")
+source("Zmethods.R")
+source("Qmethods.R")
+source("Vmethods.R")
+
+## S4 class 'SSM'
+
+initEq <- new("SSinitEq",
+ a0=c(20, 0),
+ Sigma0=matrix(0, 2, 2))
+
+## Ffct <- new("FunctionWithControl",
+## function (t, x0, v=c(0,0), u=c(0,0), control=NULL, dots=NULL)
+## {
+## call <- match.call()
+## F <- matrix(c(1, 0, 1, 0), ncol=2)
+## R <- diag(nrow(F))
+## x1 <- F%*%x0 + u + R%*%v
+## retF <- new("SSretValueF",
+## x1 = as.vector(x1), Fmat = F, Rmat = R,
+## t=t, x0=x0, v=v, u=u, control=control,
+## dots.propagated = dots, call = call,
+## diagnostics = new("SSDiagnosticRetValue"))
+## return(retF)
+## })
+
+## besser:
+F <- matrix(c(1, 0, 1, 0), ncol=2)
+Z <- matrix(c(0.3, -0.3, 1, 1), ncol=2)
+Q <- diag(c(0, 9))
+V <- diag(c(9, 9))
+
+Ffct <- createF(F)
+Zfct <- createZ(Z)
+Qfct <- createQ(Q)
+Vfct <- createV(V)
+
+## testing:
+## Ffct(1, 1:2, c(0, 0), c(0, 0), NULL, NULL)
+## Zfct(1, 1:2, c(0, 0), c(0, 0), NULL, NULL)
+## Qfct(1, 1:2, NULL, NULL, NULL)
+## Vfct(1, 1:2, NULL, NULL, NULL)
+
+stateEq <- new("SSstateEq",
+ Ffct=Ffct,
+ Qfct=Qfct)
+
+obsEq <- new("SSobsEq",
+ Zfct=Zfct,
+ Vfct=Vfct)
+
+mySSM <- new("SSM",
+ initEq=initEq,
+ statesEq=stateEq,
+ obsEq=obsEq,
+ pdim=2,
+ qdim=2)
+
+Obs <- new("SSObs",
+ Y=Y,
+ origData=NULL)
+
+times <- new("SStimes",
+ times=1:50,
+ inX=rep(TRUE, 50))
+
More information about the Robkalman-commits
mailing list