[Robkalman-commits] r75 - branches/robKalman_2012/pkg/robKalman/R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Apr 16 18:34:59 CEST 2014
Author: ruckdeschel
Date: 2014-04-16 18:34:59 +0200 (Wed, 16 Apr 2014)
New Revision: 75
Modified:
branches/robKalman_2012/pkg/robKalman/R/StateObsSimFct.R
branches/robKalman_2012/pkg/robKalman/R/recFilter4.R
branches/robKalman_2012/pkg/robKalman/R/simSSMS4.R
branches/robKalman_2012/pkg/robKalman/R/updateinitSSPredOrFilterRet.R
Log:
Mit Umsetzung begonnen
Modified: branches/robKalman_2012/pkg/robKalman/R/StateObsSimFct.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/StateObsSimFct.R 2014-04-16 15:29:40 UTC (rev 74)
+++ branches/robKalman_2012/pkg/robKalman/R/StateObsSimFct.R 2014-04-16 16:34:59 UTC (rev 75)
@@ -1,7 +1,5 @@
-new("FunctionWithControl",
-initSim <- function (initEq,
- controlInit = NULL, ...)
-{
+initSim <- new("FunctionWithControl", function (initEq,
+ controlInit = NULL, ...){
## initEq ... object of S4 class 'SSinitEq'
## controlInit ... control parameters, list
call <- match.call()
@@ -22,15 +20,12 @@
control = controlInit,
diagnostics = new("SSDiagnosticFilter"))
return(SSInitialized)
-}
-)
+})
-new("FunctionWithControl",
-stateSim <- function (i, t,
+stateSim <- new("FunctionWithControl", function (i, t,
StateSimulated,
stateEq,
- controlPred = NULL, ...)
-{
+ controlPred = NULL, ...){
## i ... loop index
## t ... time, t[i]
## PredOrFilt ... object of S4 class 'SSPredOrFilt'
@@ -47,6 +42,7 @@
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,
@@ -60,7 +56,7 @@
innov <- generateRV(stateEq at distrfct, 0*x0, Q)
x1 <- x1 + innov
- SSPredicted <- new("SSStateSimulated",
+ StateSim <- new("SSStateSimulated",
values = x1,
call = call,
variance = Q,
@@ -70,16 +66,13 @@
crtl.prpgtd = crtl.prpgtd,
control = controlPred,
diagnostics = new("SSDiagnosticFilter"))
- return(SSPredicted)
-}
-)
+ return(StateSim)
+})
-new("FunctionWithControl",
-Ysim <- function (i, t, ydim,
+Ysim <- new("FunctionWithControl", function (i, t, ydim,
StateSimulated,
obsEq,
- controlCorr = NULL, ...)
-{
+ controlCorr = NULL, ...){
## i ... loop index
## t ... time, t[i]
## Obs ... object of S4 class 'SSObs'
@@ -113,7 +106,7 @@
y <- y + eps
- SSFiltered <- new("SSObsSimulated",
+ ObsSim <- new("SSObsSimulated",
values = y,
call = call,
variance = V,
@@ -123,7 +116,6 @@
crtl.prpgtd = crtl.prpgtd,
control = controlCorr,
diagnostics = new("SSDiagnosticFilter"))
- return(SSFiltered)
-}
-)
+ return(ObsSim)
+})
Modified: branches/robKalman_2012/pkg/robKalman/R/recFilter4.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/recFilter4.R 2014-04-16 15:29:40 UTC (rev 74)
+++ branches/robKalman_2012/pkg/robKalman/R/recFilter4.R 2014-04-16 16:34:59 UTC (rev 75)
@@ -6,22 +6,22 @@
##
#######################################################
+# _<
+## ist erledigt durch initSSPredOrFiltRet() in updateinitSSPredOrFiltRet.R
+# _>
+# initPsRet <- function(SSM,tt, exosDim ){
+# ###exosDim ist die Dimensionierung der Rueckgabewerte der exoFct
+#
+# if modell has uexo uexos = matrix(...) else uexos = NULL
+# psret0 <- new("SSPredictedRet",
+# values=matrix(0,Model at pdim,length(tt)+1),
+# call = vector("list",length(tt)+1 ),
+# variance = array(0,dim=c(Model at pdim,Model at pdim,length(tt)+1)),
+ # uexo = uexos,...)
+# return(psret0)
+# }
- initPsRet <- function(SSM,tt, exosDim ){
- ###exosDim ist die Dimensionierung der Rueckgabewerte der exoFct
- if modell has uexo uexos = matrix(...) else uexos = NULL
- psret0 <- new("SSPredictedRet",
- values=matrix(0,Model at pdim,length(tt)+1),
- call = vector("list",length(tt)+1 ),
- variance = array(0,dim=c(Model at pdim,Model at pdim,length(tt)+1)),
- uexo = uexos,...)
- return(psret0)
- }
-
-## analog initPrepRet initCsRet
-
-
recFilter <- function (Model,
Obs,
times,
@@ -43,6 +43,8 @@
## time management:
tt <- times at times
inX <- times at inX
+ tT <- length(tt)+1
+ tY <- sum(inX)
loopIndex <- 1:length(tt)
nrSteps <- length(Steps)
@@ -53,39 +55,39 @@
psRet <- vector("list", nrSteps)
csRet <- vector("list", nrSteps)
- if (prep) prepret0 <- initPrepRet(SSM,tt,exox...)
- psret0 <- initPsRet(SSM,tt,exox...)
- csret0 <- initCsRet(SSM,tt,exox...)
+ withuExo <- !is.null(stateEq at uExofct)
+ withwExo <- !is.null(obsEq at wExofct)
+ withdots.prop <- (length(dots.propagated)>0)
- for(i in nrSteps){
- # if exists prepRet ..
- # prepRet0 <- new("SSPreparedRet",values=matrix)
+ ### noch herauszufinden: woher findet man raus,
+ ## ob der prepstep/predstep/corrstep control/Diagnostic hat..
- ### aus diesem Code eine Funktion machen
- if (prep) prepRet[[i]] <- prepret0
- psRet[[i]] <- psret0
- csRet[[i]] <- csret0
- }
+ withcontrol.prep <- ##!is.null(stateEq at uExofct)
+ withDiagnostic.prep <- ##!!is.null(stateEq at uExofct)
+
+ withcontrol.pred <- ##!!is.null(stateEq at uExofct)
+ withDiagnostic.pred <- ##!!is.null(stateEq at uExofct)
+
+ withcontrol.corr <- ##!!is.null(stateEq at uExofct)
+ withDiagnostic.corr <- ##!!is.null(stateEq at uExofct)
+
+ if (prep) prepret0 <- initSSPredOrFiltRet(Model at pdim, tT,
+ Model at pdim, tT, Model at qdim, tY,
+ withuExo, withwExo, withdots.prop,
+ withcontrol.prep, withDiagnostic.prep)
+ psret0 <- <- initSSPredOrFiltRet(Model at pdim, tT,
+ Model at pdim, tT, Model at qdim, tY,
+ withuExo, withwExo, withdots.prop,
+ withcontrol.pred, withDiagnostic.pred)
+ csret0 <- <- initSSPredOrFiltRet(Model at pdim, tY,
+ Model at pdim, tT, Model at qdim, tY,
+ withuExo, withwExo, withdots.prop,
+ withcontrol.corr, withDiagnostic.corr)
+
for(iStep in 1:nrStep){
- psRet[[iStep]] <- initSSPredOrFiltRet(pdim = Model at pdim,
- qdim = Model at qdim,
- tfdim = sum(inX), tpdim = length(tt),
- withuExo=!is.null(Model at SSstateEq@uExofct,
- withwExo=!is.null(Model at SSobsEq@wExofct,
- withdots.prop=(length(dots.propagated)>0),
- withcontrol=(length(control)>0), ##?
- withDiagnosticFilter=TRUE ##?
- )
- csRet[[iStep]] <- initSSPredOrFiltRet(pdim = Model at pdim,
- qdim = Model at qdim,
- tfdim = sum(inX), tpdim = length(tt),
- withuExo=!is.null(Model at SSstateEq@uExofct,
- withwExo=!is.null(Model at SSobsEq@wExofct,
- withdots.prop=(length(dots.propagated)>0),
- withcontrol=(length(control)>0), ##?
- withDiagnosticFilter=TRUE ##?
- )
-
+ if (prep) prepRet[[iStep]] <- prepret0
+ psRet[[iStep]] <- psret0
+ csRet[[iStep]] <- csret0
}
## initialization: iStep = index within different procedures
for (iStep in 1:nrStep) {
Modified: branches/robKalman_2012/pkg/robKalman/R/simSSMS4.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/simSSMS4.R 2014-04-16 15:29:40 UTC (rev 74)
+++ branches/robKalman_2012/pkg/robKalman/R/simSSMS4.R 2014-04-16 16:34:59 UTC (rev 75)
@@ -23,7 +23,6 @@
rmvnorm(1, mean=mu,sigma=Sigma)
})
-generateRV <- function(distrib)
simSSM <- function (Model, times, seed = NULL, ...)
{
@@ -48,19 +47,34 @@
tY <- tt[inX]
loopIndex <- 1:length(tt)
+ withuExo <- !is.null(stateEq at uExofct)
+ withwExo <- !is.null(obsEq at wExofct)
+ withdots.prop <- (length(dots.propagated)>0)
+
+ ### noch herauszufinden: woher findet man raus,
+ ## ob der prepstep/predstep/corrstep control/Diagnostic hat..
+
+ withcontrol <- withDiagnostic <- FALSE
+
+
## initialization of resulting objects:
- Y <- matrix(NA,Model at qdim,length(tY))
- X <- matrix(NA,Model at pdim,length(tt)+1)
+ X <- initSSPredOrFiltRet(Model at pdim, length(tt)+1, Model at pdim, length(tt)+1,
+ Model at qdim, length(tY),
+ withuExo, withwExo, withdots.prop,
+ withcontrol, withDiagnostic)
+ Y <- initSSPredOrFiltRet(Model at qdim, length(tY)+1, Model at pdim, length(tt)+1,
+ Model at qdim, length(tY),
+ withuExo, withwExo, withdots.prop,
+ withcontrol, withDiagnostic)
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 <- stateSim(i=ix, t=tt[ix],
StateSimulated=StateSimulated,
stateEq=stateEq, ...)
- X[,ix] < StateSimulated at values
+ X <- updateSSPredOrFilt(X, StateSimulated, ix)
## correction:
if(inX[ix]){ ## have an observation available
@@ -68,8 +82,9 @@
ObsSimulated <- obsSim(i=iy, t=tt[ix], ydim = Model at qdim,
StateSimulated = StateSimulated,
obsEq=obsEq, ...)
- Y[,iy] <- ObSimulated at values
+ Y <- updateSSPredOrFilt(Y, ObsSimulated, iy)
}
}
+ Simulated <- new("SSSimulated", stateSimulated=X, obsSimulated=Y)
### fehlt noch: zusammenführen der Daten....
}
\ No newline at end of file
Modified: branches/robKalman_2012/pkg/robKalman/R/updateinitSSPredOrFilterRet.R
===================================================================
--- branches/robKalman_2012/pkg/robKalman/R/updateinitSSPredOrFilterRet.R 2014-04-16 15:29:40 UTC (rev 74)
+++ branches/robKalman_2012/pkg/robKalman/R/updateinitSSPredOrFilterRet.R 2014-04-16 16:34:59 UTC (rev 75)
@@ -11,15 +11,15 @@
}
-initSSPredOrFiltRet <- function(pdim, qdim, tdim, withuExo, withwExo, withdots.prop,
+initSSPredOrFiltRet <- function(rdim, trdim, pdim, tdim, qdim, tydim, withuExo, withwExo, withdots.prop,
withcontrol, withDiagnosticFilter){
- v <- matrix(NA,pdim,tdim)
- vm <- array(NA,dim=c(pdim,pdim,tdim))
+ v <- matrix(NA,rdim,trdim)
+ vm <- array(NA,dim=c(rdim,rdim,trdim))
uExo <- if(withuExo) matrix(NA,pdim,tdim) else NULL
- wExo <- if(withwExo) matrix(NA,qdim,tdim) else NULL
- dots.prop <- if(withdots.prop) vector("list", tdim) else NULL
- control <- if(withcontrol) vector("list", tdim) else NULL
- DiagnosticFilter <- if(DiagnosticFilter) vector("list",tdim) else NULL
+ wExo <- if(withwExo) matrix(NA,qdim,tydim) else NULL
+ dots.prop <- if(withdots.prop) vector("list", trdim) else NULL
+ control <- if(withcontrol) vector("list", trdim) else NULL
+ DiagnosticFilter <- if(DiagnosticFilter) vector("list",trdim) else NULL
new("SSPredOrFiltRet", value = v, variance = vm, uExo = uExo, wExo = wExo,
dot.propagated = dot.prop, control = control,
DiagnosticFilter = DiagnosticFilter)
More information about the Robkalman-commits
mailing list