[Robkalman-commits] r71 - branches/robKalman_2012/pkg/robKalman/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Sep 12 22:12:56 CEST 2013
Author: ruckdeschel
Date: 2013-09-12 22:12:56 +0200 (Thu, 12 Sep 2013)
New Revision: 71
Added:
branches/robKalman_2012/pkg/robKalman/R/StateObsSimFct.R
branches/robKalman_2012/pkg/robKalman/R/simSSMS4.R
Modified:
branches/robKalman_2012/pkg/robKalman/R/allClass.R
branches/robKalman_2012/pkg/robKalman/R/classEKF4.R
branches/robKalman_2012/pkg/robKalman/R/recFilter4.R
Log:
?\195?\132nderungen Peter
Added: branches/robKalman_2012/pkg/robKalman/R/StateObsSimFct.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/StateObsSimFct.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/StateObsSimFct.R 2013-09-12 20:12:56 UTC (rev 71)
@@ -0,0 +1,129 @@
+new("FunctionWithControl",
+initSim <- 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
+ x1 <- generateRV(initEq at distrfct, x0, Sigma0) ### auch initEq at iExofct?
+
+ SSInitialized <- new("SSInitialized",
+ values = x1,
+ call = call,
+ variance = S0,
+ uExo = NULL,
+ wExo = NULL,
+ dots.propagated = dots.propagated,
+ crtl.prpgtd = NULL,
+ control = controlInit,
+ diagnostics = new("SSDiagnosticFilter"))
+ return(SSInitialized)
+}
+)
+
+new("FunctionWithControl",
+stateSim <- function (i, t,
+ StateSimulated,
+ stateEq,
+ controlPred = NULL, ...)
+{
+ ## i ... loop index
+ ## t ... time, t[i]
+ ## PredOrFilt ... object of S4 class 'SSPredOrFilt'
+ ## stateEq ... object of S4 class 'SSstateEq'
+ ## controlPred ... control parameters, list
+ call <- match.call()
+ dots.propagated <- list(...)
+
+ x0 <- StateSimulated at values
+ S0 <- StateSimulated at variance
+ uExo <- StateSimulated at uExo
+ wExo <- StateSimulated at wExo
+ ctrl.prpgtd <- StateSimulated at ctrl.prpgtd
+ Ffct <- stateEq at Ffct
+ Qfct <- stateEq at Qfct
+ uExofct <- stateEq at uExofct
+ if (is.null(uExofct)) uExofct <- createuExo(0)
+
+ Freturn <- Ffct(i=i, t=t, x0=x0,
+ uFct=uExofct, uOld=uExo, wNew=wExo)
+ x1 <- Freturn at x1
+ uNew <- Freturn at uNew
+
+ Qreturn <- Qfct(i=i, t=t, x0=x0)
+ Q <- Qreturn at Q
+
+ innov <- generateRV(stateEq at distrfct, 0*x0, Q)
+ x1 <- x1 + innov
+
+ SSPredicted <- new("SSStateSimulated",
+ values = x1,
+ call = call,
+ variance = Q,
+ uExo = uNew,
+ wExo = wExo,
+ dots.propagated = dots.propagated,
+ crtl.prpgtd = crtl.prpgtd,
+ control = controlPred,
+ diagnostics = new("SSDiagnosticFilter"))
+ return(SSPredicted)
+}
+)
+
+new("FunctionWithControl",
+Ysim <- function (i, t, ydim,
+ StateSimulated,
+ obsEq,
+ controlCorr = NULL, ...)
+{
+ ## i ... loop index
+ ## t ... time, t[i]
+ ## Obs ... object of S4 class 'SSObs'
+ ## StateSimulated ... object of S4 class 'SSStateSimulated'
+ ## obsEq ... object of S4 class 'SSobsEq'
+ ## controlCorr ... control parameters, list
+ call <- match.call()
+ dots.propagated <- list(...)
+
+ y <- numeric(ydim)
+ x1 <- StateSimulated at values
+ S1 <- StateSimulated at variance
+ uExo <- StateSimulated at uExo
+ wExo <- StateSimulated at wExo
+ ctrl.prpgtd <- StateSimulated at ctrl.prpgtd
+ Zfct <- obsEq at Zfct
+ Vfct <- obsEq at Vfct
+ wExofct <- obsEq at wExofct
+ if (is.null(wExofct)) wExofct <- createwExo(0)
+
+ Zreturn <- Zfct(i=i, t=t, x1=x1, y=y,
+ wFct=wExofct, uNew=uExo, wOld=wExo)
+ y <- Zreturn at y
+ C <- Zreturn at ZJcb
+ D <- Zreturn at TJcb
+ wNew <- Zreturn at wNew
+
+ Vreturn <- Vfct(i=i, t=t, x1=x1) ### nicht auch von y abhängig??
+ V <- Vreturn at V
+ eps <-generateRV(obsEq at distrfct, 0*y, V)
+
+ y <- y + eps
+
+ SSFiltered <- new("SSObsSimulated",
+ values = y,
+ call = call,
+ variance = V,
+ uExo = uExo,
+ wExo = wNew,
+ dots.propagated = dots.propagated,
+ crtl.prpgtd = crtl.prpgtd,
+ control = controlCorr,
+ diagnostics = new("SSDiagnosticFilter"))
+ return(SSFiltered)
+}
+)
+
Modified: branches/robKalman_2012/pkg/robKalman/R/allClass.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/allClass.R 2013-07-17 16:53:58 UTC (rev 70)
+++ branches/robKalman_2012/pkg/robKalman/R/allClass.R 2013-09-12 20:12:56 UTC (rev 71)
@@ -55,7 +55,8 @@
setClassUnion("OptionalDistribution",
## c("Distribution","NULL") # S4 class 'Distribution' missing!
- c("NULL")
+ "ANY"
+# c("NULL", "function")
)
@@ -169,6 +170,7 @@
### and as slot classes (in variant as multi-step in time) for return value
### of recFilter
+
setClass("SSPredOrFilt",
representation = representation(values = "numeric",
call = "OptionalCall",
@@ -179,8 +181,16 @@
ctrl.prpgtd = "OptionalList",
control = "OptionalList",
diagnostics = "SSDiagnosticFilter"),
- contains = "VIRTUAL"
+ contains = c("VIRTUAL")
)
+
+setClass("SSStateSimulated",
+ contains = "SSPredOrFilt"
+ )
+setClass("SSObsSimulated",
+ contains = "SSPredOrFilt"
+ )
+
setClass("SSInitialized",
contains = "SSPredOrFilt"
)
Modified: branches/robKalman_2012/pkg/robKalman/R/classEKF4.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/classEKF4.R 2013-07-17 16:53:58 UTC (rev 70)
+++ branches/robKalman_2012/pkg/robKalman/R/classEKF4.R 2013-09-12 20:12:56 UTC (rev 71)
@@ -142,7 +142,7 @@
D <- Zreturn at TJcb
wNew <- Zreturn at wNew
- Vreturn <- Vfct(i=i, t=t, x1=x1)
+ Vreturn <- Vfct(i=i, t=t, x1=x1) ### nicht auch von y abhängig??
V <- Vreturn at V
Delta <- .getDelta(S1=S1, C=C, D=D, V=V)
Modified: branches/robKalman_2012/pkg/robKalman/R/recFilter4.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/recFilter4.R 2013-07-17 16:53:58 UTC (rev 70)
+++ branches/robKalman_2012/pkg/robKalman/R/recFilter4.R 2013-09-12 20:12:56 UTC (rev 71)
@@ -102,4 +102,5 @@
}else{
cs <- ps
}
- }
\ No newline at end of file
+ }
+ }
\ No newline at end of file
Added: branches/robKalman_2012/pkg/robKalman/R/simSSMS4.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/simSSMS4.R (rev 0)
+++ branches/robKalman_2012/pkg/robKalman/R/simSSMS4.R 2013-09-12 20:12:56 UTC (rev 71)
@@ -0,0 +1,75 @@
+#######################################################
+##
+## simulating data from SSM, S4
+## author: Peter Ruckdeschel
+## version: 0.1 (created: 2013-08-02)
+##
+#######################################################
+
+### S4-method: input distrib of type OptionalDistribution
+
+if(!isGeneric("generateRV"))
+ setGeneric("generateRV", function(distrib,...) standardGeneric("generateRV"))
+
+setMethod("generateRV", "distribution", function(distrib,...){
+ r(distrib)(1)
+})
+
+setMethod("generateRV", "function", function(distrib,mu,Sigma){
+ distrib(mu,Sigma)
+})
+
+setMethod("generateRV", "NULL", function(distrib,mu,Sigma){
+ rmvnorm(1, mean=mu,sigma=Sigma)
+})
+
+generateRV <- function(distrib)
+
+simSSM <- function (Model, times, seed = NULL, ...)
+{
+ ## Model ... object of S4 class 'SSM'
+ ## Obs ... object of S4 class 'SSObs'
+ ## times ... object of S4 class 'SStimes'
+ ## Steps ... object of S4 class 'SSFilterOrSmoother'
+
+ if(!is.null(seed)) set.seed(seed)
+
+ call <- match.call()
+ dots.propagated <- list(...)
+
+ ## unwrapping:
+ initEq <- Model at initEq
+ stateEq <- Model at stateEq
+ obsEq <- Model at obsEq
+
+ ## time management:
+ tt <- times at times
+ inX <- times at inX
+ tY <- tt[inX]
+ loopIndex <- 1:length(tt)
+
+ ## initialization of resulting objects:
+ Y <- matrix(NA,Model at qdim,length(tY))
+ X <- matrix(NA,Model at pdim,length(tt)+1)
+
+
+ StateSimulated <- initSim(initEq, controlInit = NULL, ...)
+ X[,1] <- StateSimulated at values
+ for(ix in loopIndex+1){
+ ## state simulation
+ StateSimulated <- stateSim(i=ix, t=tt[ix],
+ StateSimulated=StateSimulated,
+ stateEq=stateEq, ...)
+ X[,ix] < StateSimulated at values
+
+ ## correction:
+ if(inX[ix]){ ## have an observation available
+ iy <- iy + 1
+ ObsSimulated <- obsSim(i=iy, t=tt[ix], ydim = Model at qdim,
+ StateSimulated = StateSimulated,
+ obsEq=obsEq, ...)
+ Y[,iy] <- ObSimulated at values
+ }
+ }
+ ### fehlt noch: zusammenführen der Daten....
+}
\ No newline at end of file
More information about the Robkalman-commits
mailing list