[Yuima-commits] r412 - in pkg/yuima: . R
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Mar 10 22:35:01 CET 2016
Author: lorenzo
Date: 2016-03-10 22:35:00 +0100 (Thu, 10 Mar 2016)
New Revision: 412
Modified:
pkg/yuima/DESCRIPTION
pkg/yuima/NAMESPACE
pkg/yuima/R/yuima.model.R
Log:
Added rbind for yuima.model
Modified: pkg/yuima/DESCRIPTION
===================================================================
--- pkg/yuima/DESCRIPTION 2016-03-09 20:28:37 UTC (rev 411)
+++ pkg/yuima/DESCRIPTION 2016-03-10 21:35:00 UTC (rev 412)
@@ -1,7 +1,7 @@
Package: yuima
Type: Package
Title: The YUIMA Project Package for SDEs
-Version: 1.0.83
+Version: 1.0.84
Depends: R(>= 2.10.0), methods, zoo, stats4, utils, expm, cubature, mvtnorm
Author: YUIMA Project Team
Maintainer: Stefano M. Iacus <stefano.iacus at unimi.it>
Modified: pkg/yuima/NAMESPACE
===================================================================
--- pkg/yuima/NAMESPACE 2016-03-09 20:28:37 UTC (rev 411)
+++ pkg/yuima/NAMESPACE 2016-03-10 21:35:00 UTC (rev 412)
@@ -109,6 +109,7 @@
"Fnorm",
"asymptotic_term",
"cbind.yuima"
+#"rbind.yuima"
)
## function which we want to expose to the user
@@ -191,7 +192,7 @@
export(mmfrac)
export(cbind.yuima)
-
+#export(rbind.yuima)
S3method(print, phitest)
S3method(print, qgv)
S3method(print, mmfrac)
@@ -205,6 +206,7 @@
S3method(toLatex, yuima.model)
S3method(toLatex, yuima.carma)
S3method(toLatex, yuima.cogarch)
+S3method(rbind, yuima.model)
S3method(plot, yuima.llag) # Oct. 10, 2015
S3method(plot, yuima.mllag) # Oct. 10, 2015
Modified: pkg/yuima/R/yuima.model.R
===================================================================
--- pkg/yuima/R/yuima.model.R 2016-03-09 20:28:37 UTC (rev 411)
+++ pkg/yuima/R/yuima.model.R 2016-03-10 21:35:00 UTC (rev 412)
@@ -56,7 +56,7 @@
# J.flag){
# .Object at drift <- drift
# .Object at diffusion <- diffusion
-# .Object at hurst <- hurst
+# .Object at hurst <- hurst
# .Object at jump.coeff <- jump.coeff
# .Object at measure <- measure
# .Object at measure.type <- measure.type
@@ -73,8 +73,8 @@
# return(.Object)
# })
-# 23/11 we need to provide the default values for the yuima.model object class
-# in order to construct a new class that inherits from yuima.model class
+# 23/11 we need to provide the default values for the yuima.model object class
+# in order to construct a new class that inherits from yuima.model class
setMethod("initialize", "yuima.model",
function(.Object,
@@ -97,7 +97,7 @@
J.flag = logical()){
.Object at drift <- drift
.Object at diffusion <- diffusion
- .Object at hurst <- hurst
+ .Object at hurst <- hurst
.Object at jump.coeff <- jump.coeff
.Object at measure <- measure
.Object at measure.type <- measure.type
@@ -130,20 +130,20 @@
solve.variable,
xinit=NULL){
## we need a temp env for simplifications
-
+
yuimaENV <- new.env()
##::measure and jump term #####################################
-
+
##::initialize objects ########
MEASURE <- list()
-
+
##::end initialize objects ########
-
+
##::make type function list ####
CPlist <- c("dnorm", "dgamma", "dexp", "dconst")
codelist <- c("rIG", "rNIG", "rgamma", "rbgamma", "rngamma", "rstable")
##::end make type function list ####
-
+
if(!length(measure.type)){
if( length(jump.coeff) || length(measure) ){
yuima.warn("measure type does not match with jump term.")
@@ -155,13 +155,13 @@
if( !length(jump.coeff) || !length(measure) ){
yuima.warn("measure type isn't matched with jump term.")
return(NULL)
- # }else
+ # }else
# if(length(jump.coeff)!=1){
# yuima.warn("multi dimentional jump term is not supported yet.")
- #
+ #
# return(NULL)
# }
-
+
} else if(measure.type=="CP"){ ##::CP
# if(length(measure)!=2){
# yuima.warn(paste("length of measure must be two on type", measure.type, "."))
@@ -179,7 +179,7 @@
if(is.null(tmpc)){
names(measure) <- c("intensity", "df","dimension")
}else{
- whichint <- match("intensity", tmpc)
+ whichint <- match("intensity", tmpc)
whichdf <- match("df", tmpc)
if(!is.na(whichint)){
if(names(measure)[-whichint]=="" || names(measure)[-whichint]=="df"){
@@ -202,7 +202,7 @@
}
##::end naming measure list ########
}
-
+
##::check df name ####################
tmp <- regexpr("\\(", measure$df)[1]
measurefunc <- substring(measure$df, 1, tmp-1)
@@ -215,18 +215,18 @@
MEASURE$df$func <- eval(parse(text=measurefunc))
MEASURE$df$expr <- parse(text=measure$df)
MEASURE$intensity <- parse(text=measure$intensity)
-
- measure.par <- unique( c( all.vars(MEASURE$intensity), all.vars(MEASURE$df$expr) ) )
+
+ measure.par <- unique( c( all.vars(MEASURE$intensity), all.vars(MEASURE$df$expr) ) )
##measure.par$intensity <- unique(all.vars(MEASURE$intensity))
##::end check df name ####################
##::end CP
-
+
} else if(measure.type=="code"){ ##::code
if(length(measure)!=1){
yuima.warn(paste("length of measure must be one on type", measure.type, "."))
return(NULL)
}
-
+
if(!is.list(measure)){
measure <- list(df=measure)
}else{
@@ -243,7 +243,7 @@
}
##::end naming measure list #############
}
-
+
##::check df name ####################
tmp <- regexpr("\\(", measure$df)[1]
measurefunc <- substring(measure$df, 1, tmp-1)
@@ -255,7 +255,7 @@
}
##MEASURE$df$func <- eval(parse(text=measurefunc))
MEASURE$df$expr <- parse(text=measure$df)
-
+
measure.par <- unique(all.vars(MEASURE$df$expr))
##::end check df name ####################
##::end code
@@ -264,7 +264,7 @@
yuima.warn(paste("length of measure must be one on type", measure.type, "."))
return(NULL)
}
-
+
if(!is.list(measure)){
measure <- list(df=measure)
}else{
@@ -272,7 +272,7 @@
yuima.warn("multi dimentional jump term is not supported yet.")
return(NULL)
}
-
+
##::naming measure list #############
if(is.null(names(measure))){
names(measure) <- "df"
@@ -282,7 +282,7 @@
}
##::end naming measure list #############
}
-
+
##::check df name ####################
tmp <- regexpr("\\(", measure[[names(measure)]])[1]
measurefunc <- substring(measure[[names(measure)]], 1, tmp-1)
@@ -295,7 +295,7 @@
}
MEASURE[[names(measure)]]$func <- eval(parse(text=measurefunc))
MEASURE[[names(measure)]]$expr <- parse(text=measure[[names(measure)]])
-
+
measure.par <- unique(all.vars(MEASURE[[names(measure)]]$expr))
##::end check df name ####################
##::end density
@@ -306,9 +306,9 @@
n.eqn3 <- 1
n.jump <- 1
}
-
+
##::end measure and jump term #####################################
-
+
##:: check for errors and reform values
if(any(time.variable %in% state.variable)){
yuima.warn("time and state(s) variable must be different.")
@@ -321,7 +321,7 @@
n.eqn1 <- dim(drift)[1]
n.drf <- dim(drift)[2]
}
-
+
if(is.null(dim(diffusion))){ # this is a vector
n.eqn2 <- length(diffusion)
n.noise <- 1
@@ -329,26 +329,26 @@
n.eqn2 <- dim(diffusion)[1]
n.noise <- dim(diffusion)[2]
}
-
+
if(is.null(diffusion)){
diffusion <- rep("0", n.eqn1)
n.eqn2 <- n.eqn1
n.noise <- 1
}
-
+
## TBC
n.eqn3 <- n.eqn1
-
+
if(!length(measure)){
n.eqn3 <- n.eqn1
}
-
+
if(n.eqn1 != n.eqn2 || n.eqn1 != n.eqn3){
yuima.warn("Malformed model, number of equations in the drift and diffusion do not match.")
return(NULL)
}
n.eqn <- n.eqn1
-
+
if(is.null(xinit)){
# xinit <- numeric(n.eqn)
xinit <- character(n.eqn)
@@ -360,7 +360,7 @@
return(NULL)
}
}
-
+
if(missing(solve.variable)){
yuima.warn("Solution variable (lhs) not specified. Trying to use state variables.")
solve.variable <- state.variable
@@ -369,18 +369,18 @@
yuima.warn("Malformed model, number of solution variables (lhs) do no match number of equations (rhs).")
return(NULL)
}
-
+
loc.drift <- matrix(drift, n.eqn, n.drf)
loc.diffusion <- matrix(diffusion, n.eqn, n.noise)
# Modification starting point 6/11
loc.xinit<-matrix(xinit,n.eqn,n.drf)
-
+
##:: allocate vectors
DRIFT <- vector(n.eqn, mode="expression")
DIFFUSION <- vector(n.eqn, mode="list")
# Modification starting point 6/11
XINIT<-vector(n.eqn, mode = "expression")
-
+
##:: function to make expression from drift characters
pre.proc <- function(x){
for(i in 1:length(x)){
@@ -413,11 +413,11 @@
if(length(expr)==0){
expr <- expression(0) # expr must have something
}
-# DIFFUSION[[i]][j] <- expr
+# DIFFUSION[[i]][j] <- expr
#22/11
DIFFUSION[[i]][j] <- yuima.Simplifyobj(expr)
}
-#22/11
+#22/11
#if (length(JUMP)>0){
# JUMP[i] <- parse(text=jump.coeff[i])
@@ -468,24 +468,24 @@
#print(str(JUMP))
#
-
+
##:: get parameters in drift expression
drift.par <- unique(all.vars(DRIFT))
# Modification starting point 6/11
xinit.par <- unique(all.vars(XINIT))
-
+
drift.idx <- as.numeric(na.omit(match(c(state.variable, time.variable, jump.variable, solve.variable), drift.par)))
if(length(drift.idx)>0){
drift.par <- drift.par[-drift.idx]
}
-
+
##:: get parameters in diffusion expression
diff.par <- unique(unlist(lapply(DIFFUSION, all.vars)))
diff.idx <- as.numeric(na.omit(match(c(state.variable, time.variable, jump.variable, solve.variable), diff.par)))
if(length(diff.idx)>0){
diff.par <- diff.par[-diff.idx]
}
-
+
##:: get parameters in jump expression
J.flag <- FALSE
# jump.par <- unique(all.vars(JUMP))
@@ -499,34 +499,34 @@
if(length(jump.idx)>0){
jump.par <- jump.par[-jump.idx]
}
-
+
##:: get parameters in measure expression
measure.idx <- as.numeric(na.omit(match(c(state.variable, time.variable, jump.variable, solve.variable), measure.par)))
if(length(measure.idx)>0){
measure.par <- measure.par[-measure.idx]
}
-
+
##:: order parameters for 'yuima.pars'
##id1 <- which(diff.par %in% drift.par)
##id2 <- which(drift.par %in% diff.par)
##common <- unique(c(diff.par[id1], drift.par[id2]))
common <- c(drift.par, diff.par)
common <- common[duplicated(common)]
-
+
common1<-common
- # modification 06/11 common1 contains only
- # parameters that appear in both drift and diffusion terms.
-
- # Modification 06/11 common contains only parameters that appear
- # in drift, diff, Jump and xinit
+ # modification 06/11 common1 contains only
+ # parameters that appear in both drift and diffusion terms.
+
+ # Modification 06/11 common contains only parameters that appear
+ # in drift, diff, Jump and xinit
if (length(xinit)) {
common <- c(common, xinit.par)
common <- common[duplicated(common)]
common <- c(common, xinit.par)
common <- common[duplicated(common)]
}
-
-
+
+
if(length(measure)){
common <- c(common, jump.par)
common <- common[duplicated(common)]
@@ -535,7 +535,7 @@
}
# all.par <- unique(c(drift.par, diff.par, jump.par, measure.par))
all.par <- unique(c(drift.par, diff.par, jump.par, measure.par, xinit.par))
-
+
##:: instanciate class
tmppar <- new("model.parameter",
all= all.par,
@@ -553,7 +553,7 @@
jump.coeff=JUMP,
measure= MEASURE,
measure.type= measure.type,
- parameter= tmppar,
+ parameter= tmppar,
state.variable= state.variable,
jump.variable= jump.variable,
time.variable= time.variable,
@@ -572,3 +572,114 @@
J.flag <- J.flag)
return(tmp)
}
+# yuima.model rbind
+
+# setGeneric("rbind.yuima",
+# function(x, ...)
+# standardGeneric("rbind.yuima")
+# )
+
+# setMethod("cbind.yuima", signature(x="yuima"),
+# function(x, ...){
+# ##:: init
+# y.list <- list(x, ...)
+# y.num <- length(y.list)
+#
+# ##:: bind yuima.data in yuima
+#
+# ##:: return result
+# return(NULL)
+# }
+# )
+
+# setMethod("rbind.yuima", signature(x="yuima.model"),
+# function(x, ...){
+# y.list <- list(x, ...)
+# y.num <- length(y.list)
+# res <- aux.rbind.model(y.list,y.num)
+# return(res)
+# }
+# )
+
+rbind.yuima.model <- function(x, ...){
+ y.list <- list(x, ...)
+ y.num <- length(y.list)
+ res <- aux.rbind.model(y.list,y.num)
+ return(res)
+}
+
+aux.rbind.model<-function(y.list,y.num){
+ lapply(y.list, FUN = check.yuima.model)
+
+ drift <- lapply(y.list, FUN = extract.model, type = "drift")
+ diffusion <- lapply(y.list, FUN = extract.model, type = "diffusion")
+ solve.variable <- lapply(y.list, FUN = extract.model, type = "solve.variable")
+ state.variable <- lapply(y.list, FUN = extract.model, type = "state.variable")
+ xinit <- lapply(y.list, FUN = extract.model, type = "xinit")
+ noise.number <- lapply(y.list, FUN = extract.model, type = "noise.number")
+ equation.number <- lapply(y.list, FUN = extract.model, type = "equation.number")
+ #Until Here only diffusion process
+ drift <- lapply(drift, FUN = ExpToString)
+ drift <- unlist(drift)
+ # drift
+ nrow.diff <- sum(unlist(equation.number))
+ ncol.diff <- sum(unlist(noise.number))
+ matr.diff <- matrix("0", nrow = nrow.diff, ncol = ncol.diff)
+ extrinf <- 1
+ extrsup <- noise.number[[1]]
+ j <- 1
+ cond.eq <- equation.number[[1]]
+ cond.eq1 <- 0
+ for(i in c(1:nrow.diff)){
+ if(i <= cond.eq){
+ dum <- ExpToString(diffusion[[j]][[i-cond.eq1]])
+ matr.diff[i,extrinf:extrsup] <- dum
+ if(i == equation.number[[j]]){
+ extrinf <- extrsup+1
+ j <- j+1
+ if(j <= nrow.diff){
+ extrsup <- extrsup + equation.number[[j]]
+ cond.eq1 <- i
+ cond.eq <- cond.eq + equation.number[[j]]
+ }
+ }
+ }
+ }
+ solve.variable <- lapply(solve.variable, FUN = ExpToString, cond = FALSE)
+ solve.variable <- unlist(solve.variable)
+ state.variable <- lapply(state.variable, FUN = ExpToString, cond = FALSE)
+ state.variable <- unlist(state.variable)
+ xinit <- lapply(xinit, FUN = ExpToString, cond = FALSE)
+ xinit <- unlist(xinit)
+ mod <- setModel(drift = drift, diffusion = matr.diff,
+ solve.variable = solve.variable, state.variable = state.variable,
+ xinit = xinit)
+ return(mod)
+}
+
+ExpToString <- function(x, cond = TRUE){
+ dum <- unlist(strsplit(toString(x),split=", "))
+ if(cond)
+ dum <- substr(dum, 2, nchar(dum)-1)
+ return(dum)
+}
+
+extract.model <- function(x, type = "drift"){
+ res<- slot(x,type)
+ return(res)
+}
+
+check.yuima.model <- function(x){
+ if(is.CARMA(x)){
+ yuima.warn("The cbind for CARMA will be implemented as soon as possible")
+ return(NULL)
+ }
+ if(is.COGARCH(x)){
+ yuima.warn("The cbind for COGARCH will be implemented as soon as possible")
+ return(NULL)
+ }
+ if(is.Poisson(x)){
+ yuima.warn("The cbind for Poisson will be implemented as soon as possible")
+ return(NULL)
+ }
+}
More information about the Yuima-commits
mailing list