[Yuima-commits] r757 - pkg/yuima/R

[noreply at r-forge.r-project.org]

Author: kyuta
Date: 2021-09-24 12:58:35 +0200 (Fri, 24 Sep 2021)
New Revision: 757

Added:
   pkg/yuima/R/changeFixedToConstant.R
Log:
add changeFixedToConstant.R

Added: pkg/yuima/R/changeFixedToConstant.R
===================================================================
--- pkg/yuima/R/changeFixedToConstant.R	                        (rev 0)
+++ pkg/yuima/R/changeFixedToConstant.R	2021-09-24 10:58:35 UTC (rev 757)
@@ -0,0 +1,167 @@
+## 7/8/2021 Kito
+## Some functions didn't work when 'fixed' parameters are given. (at present, qmle and adaBayes)
+## We added functions below to allow functions above to work with fixed params by rewriting yuima model. 
+transform.drift <- function(drift, fixed, unfixed.nms, state.nms ,index, unfixed.vals, state.vals){## Kurisaki 4/10/2021
+  drift <- drift
+  fixed <- fixed
+  unfixed.nms <- unfixed.nms
+  state.nms <- state.nms
+  unfixed.vals <-  unfixed.vals
+  state.vals <- state.vals
+  
+  ## substitute for the fixed parameters
+  for(var in names(fixed)) {
+      assign(var, fixed[[var]])
+  }
+  
+  ## substitute for the unfixed parameters
+  i <- 1
+  for(nm in unfixed.nms) {
+      assign(nm, unfixed.vals[i])
+      i <- i+1
+  }
+
+  ## substitute for the state parameters
+  i <- 1
+  for(nm in state.nms) {
+    assign(nm, state.vals[,i])
+    i <- i+1
+  }
+  
+  eval(drift[index])
+}
+
+transform.diffusion <- function(diffusion, fixed, unfixed.nms, state.nms, row, index, unfixed.vals, state.vals){
+  diffusion <- diffusion
+  fixed <- fixed
+  unfixed.nms <- unfixed.nms
+  state.nms <- state.nms
+  unfixed.vals <-  unfixed.vals
+  state.vals <- state.vals
+  
+  ## substitute for the fixed parameters
+  for(var in names(fixed)) {
+      assign(var, fixed[[var]])
+  }
+  
+  ## substitute x for the unfixed parameters
+  i <- 1
+  for(nm in unfixed.nms) {
+      assign(nm, unfixed.vals[i])
+      i <- i+1
+  }
+  ## substitute for the state parameters
+  i <- 1
+  for(nm in state.nms) {
+    assign(nm, state.vals[,i])
+    i <- i+1
+  }
+  
+  eval(diffusion[[row]][index])
+}
+
+transform.jump <- function(jump, fixed, unfixed.nms, state.nms, row, index, unfixed.vals, state.vals){
+  jump <- jump
+  fixed <- fixed
+  unfixed.nms <- unfixed.nms
+  state.nms <- state.nms
+  unfixed.vals <-  unfixed.vals
+  state.vals <- state.vals
+  
+  ## substitute for the fixed parameters
+  for(var in names(fixed)) {
+      assign(var, fixed[[var]])
+  }
+  
+  ## substitute for the unfixed parameters
+  i <- 1
+  for(nm in unfixed.nms) {
+      assign(nm, unfixed.vals[i])
+      i <- i+1
+  }
+  ## substitute for the state parameters
+  i <- 1
+  for(nm in state.nms) {
+    assign(nm, state.vals[,i])
+    i <- i+1
+  }
+  
+  eval(jump[[row]][index])
+}
+
+changeFixedParametersToConstant <- function(yuima, fixed) {
+    env <- new.env() # environment to calculate estimation
+    
+    yuima = yuima
+    fixed = fixed
+    
+    # list of names of unfixed parameters
+    drift.unfixed.nms = yuima at model@parameter at drift[!is.element(yuima at model@parameter at drift, names(fixed))]
+    diffusion.unfixed.nms = yuima at model@parameter at diffusion[!is.element(yuima at model@parameter at diffusion, names(fixed))]
+
+    # list of names of state variables
+    state.nms = yuima at model@state.variable
+    
+    # arguments for new.drift.func & new.diffusion.func
+    state.vals = paste("matrix(c(", paste(state.nms, collapse=", "), "), ncol=", length(state.nms),")")
+    drift.unfixed.vals = paste("c(", paste(drift.unfixed.nms, collapse=", "), ")")
+    diffusion.unfixed.vals = paste("c(", paste(diffusion.unfixed.nms, collapse=", "), ")")
+    
+    new.drift.func <- function(index, unfixed.vals, state.vals){transform.drift(yuima at model@drift, fixed, drift.unfixed.nms, state.nms, index, unfixed.vals, state.vals)}
+    new.diffusion.func <- function(row, index, unfixed.vals, state.vals){transform.diffusion(yuima at model@diffusion, fixed, diffusion.unfixed.nms, state.nms, row, index, unfixed.vals, state.vals)}
+
+    # new drift and diffusion term
+    transformed.drift <- paste("new.drift.func(", 1:length(yuima at model@drift), ", ", drift.unfixed.vals, ", ", state.vals, ")", sep="")
+
+    vector.diffusion <- c()
+    for(row in 1:length(yuima at model@diffusion)) {
+      vector.diffusion <- c(vector.diffusion, paste("new.diffusion.func(", row, ", ", 1:length(yuima at model@diffusion[[row]]), ", ", diffusion.unfixed.vals, ", ", state.vals, ")", sep=""))
+    }
+    transformed.diffusion <- matrix(vector.diffusion, nrow = length(yuima at model@diffusion),byrow=T)
+
+    # new jump term
+    if(length(yuima at model@jump.coeff) > 0) {
+      jump.unfixed.nms <- yuima at model@parameter at jump[!is.element(yuima at model@parameter at jump, names(fixed))]
+      jump.unfixed.vals = paste("c(", paste(jump.unfixed.nms, collapse=", "), ")")
+      new.jump.func <- function(row, index, unfixed.vals, state.vals){transform.jump(yuima at model@jump.coeff, fixed, jump.unfixed.nms, state.nms, row, index, unfixed.vals, state.vals)}
+      vector.jump <- c()
+      for(row in 1:length(yuima at model@jump.coeff)) {
+        vector.jump <- c(vector.jump, paste("new.jump.func(", row, ", ", 1:length(yuima at model@jump.coeff[[row]]), ", ", jump.unfixed.vals, ", ", state.vals, ")", sep=""))
+      }
+      transformed.jump <- matrix(vector.jump, nrow = length(yuima at model@jump.coeff),byrow=T)
+
+      new.measure = list()
+      measure.params <- yuima at model@parameter at measure
+      df.measure.params <- measure.params
+      if(yuima at model@measure.type=="CP"){
+        intensity <- as.character(yuima at model@measure$intensity)
+        if(is.element(intensity, names(fixed))) {
+          df.measure.params <- df.measure.params[-which(df.measure.params %in% intensity)]
+          intensity = as.character(fixed[intensity])
+        }
+        new.measure[["intensity"]] <- intensity
+      }
+      df <- yuima at model@measure$df
+      expr <- df$expr
+      cal <- as.call(expr[[1]])
+      params <- as.list(cal[-1])
+      for(i in 1:length(params)) {
+        if(is.element(c(params[[i]]), names(fixed))) {
+          params[[i]] <- fixed[[params[[i]]]]
+        }
+      }
+      cal[-1] <- as.call(params)
+      new.measure[["df"]] <- list(as.character(as.expression(cal)))
+    } else {
+      transformed.jump <- NULL
+      new.measure <- list()
+    }
+
+    new.ymodel <- setModel(drift = transformed.drift, diffusion = transformed.diffusion, hurst = yuima at model@hurst, 
+      jump.coeff = transformed.jump, measure = new.measure, measure.type = yuima at model@measure.type, 
+      state.variable = yuima at model@state.variable, jump.variable = yuima at model@jump.variable, 
+      time.variable = yuima at model@time.variable, solve.variable = yuima at model@solve.variable, 
+      xinit = yuima at model@xinit)
+    new.yuima <- setYuima(data = yuima at data, model = new.ymodel, sampling = yuima at sampling, characteristic = yuima at characteristic, functional = yuima at functional)
+    return(list(new.yuima=new.yuima, env=env))
+}
\ No newline at end of file