[Yuima-commits] r531 - in pkg/yuimaGUI: . R inst/yuimaGUI
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Dec 1 16:09:41 CET 2016
Author: phoenix844
Date: 2016-12-01 16:09:41 +0100 (Thu, 01 Dec 2016)
New Revision: 531
Modified:
pkg/yuimaGUI/DESCRIPTION
pkg/yuimaGUI/R/sourceCodeYuimaGUI.R
pkg/yuimaGUI/inst/yuimaGUI/global.R
pkg/yuimaGUI/inst/yuimaGUI/server.R
pkg/yuimaGUI/inst/yuimaGUI/ui.R
Log:
version for CRAN
Modified: pkg/yuimaGUI/DESCRIPTION
===================================================================
--- pkg/yuimaGUI/DESCRIPTION 2016-11-29 17:19:45 UTC (rev 530)
+++ pkg/yuimaGUI/DESCRIPTION 2016-12-01 15:09:41 UTC (rev 531)
@@ -1,10 +1,10 @@
Package: yuimaGUI
Type: Package
Title: A Graphical User Interface for the Yuima Package
-Version: 0.9.3
+Version: 0.9.4
Author: YUIMA Project Team
Maintainer: Emanuele Guidotti <emanuele.guidotti at studenti.unimi.it>
Description: Provides a graphical user interface for the yuima package.
License: GPL-2
Depends: R(>= 3.0.0)
-Imports: DT (>= 0.2), shinyjs, shiny, shinydashboard, shinyBS, yuima, quantmod, sde, ggplot2
+Imports: DT (>= 0.2), shinyjs, shiny, shinydashboard, shinyBS, yuima, quantmod, sde, ggplot2
\ No newline at end of file
Modified: pkg/yuimaGUI/R/sourceCodeYuimaGUI.R
===================================================================
--- pkg/yuimaGUI/R/sourceCodeYuimaGUI.R 2016-11-29 17:19:45 UTC (rev 530)
+++ pkg/yuimaGUI/R/sourceCodeYuimaGUI.R 2016-12-01 15:09:41 UTC (rev 531)
@@ -1,8 +1,8 @@
yuimaGUI <- function() {
- shiny::runApp(
+ invisible(shiny::runApp(
system.file(
"yuimaGUI",
package = "yuimaGUI"
)
- )
+ ))
}
Modified: pkg/yuimaGUI/inst/yuimaGUI/global.R
===================================================================
--- pkg/yuimaGUI/inst/yuimaGUI/global.R 2016-11-29 17:19:45 UTC (rev 530)
+++ pkg/yuimaGUI/inst/yuimaGUI/global.R 2016-12-01 15:09:41 UTC (rev 531)
@@ -8,11 +8,7 @@
require(shinyBS)
require(ggplot2)
-options(warn=-1)
-if(!exists("yuimaGUItable"))
- yuimaGUItable <<- reactiveValues(series=data.frame(), model=data.frame(), simulation=data.frame(), hedging=data.frame())
-
if(!exists("yuimaGUIdata"))
yuimaGUIdata <<- reactiveValues(series=list(), cp=list(), cpYuima=list(), model=list(), simulation=list(), hedging = list(), llag = list(), cluster = list())
@@ -28,1430 +24,3 @@
if(!exists("usr_models"))
usr_models <<- reactiveValues(model=list(), simulation=list())
-
-rbind.fill <- function(..., rep = NA){
- dots <- list(...)
- names <- c()
- for (i in length(dots):1){
- if (length(rownames(dots[[i]]))==0)
- dots[i] <- NULL
- else
- names <- unique(c(names, colnames(dots[[i]])))
- }
- for (symb in names)
- for (i in 1:length(dots))
- if (!(symb %in% colnames(dots[[i]])))
- dots[[i]][,symb] <- rep
- return (do.call("rbind", dots))
-}
-
-melt <- function(x){
- V1 <- rep(rownames(x), ncol(x))
- V2 <- sort(V1)
- xx <- data.frame(Var1 = V1, Var2 = V2, value = NA)
- for (i in 1:nrow(xx)) xx[i,"value"] <- x[as.character(xx[i,"Var1"]), as.character(xx[i,"Var2"])]
- return(xx)
-}
-
-mode <- function(x) {
- ux <- unique(x)
- ux[which.max(tabulate(match(x, ux)))]
-}
-
-observeEvent(yuimaGUIdata$series, priority = 10, {
- yuimaGUItable$series <<- data.frame()
- for (symb in names(yuimaGUIdata$series)){
- test <- try(rbind(yuimaGUItable$series, data.frame(Symb = as.character(symb), From = as.character(start(yuimaGUIdata$series[[symb]])), To = as.character(end(yuimaGUIdata$series[[symb]])))))
- if (class(test)!="try-error")
- yuimaGUItable$series <<- test
- else
- yuimaGUIdata$series <<- yuimaGUIdata$series[-which(names(yuimaGUIdata$series)==symb)]
- }
- if (length(yuimaGUItable$series)!=0)
- rownames(yuimaGUItable$series) <<- yuimaGUItable$series[,"Symb"]
-})
-
-observeEvent(yuimaGUIdata$model, priority = 10, {
- yuimaGUItable$model <<- data.frame()
- for (symb in names(yuimaGUIdata$model)){
- for (i in 1:length(yuimaGUIdata$model[[symb]])){
- newRow <- data.frame(
- Symb = as.character(symb),
- Class = as.character(yuimaGUIdata$model[[symb]][[i]]$info$class),
- Model = as.character(yuimaGUIdata$model[[symb]][[i]]$info$modName),
- Jumps = as.character(yuimaGUIdata$model[[symb]][[i]]$info$jumps),
- From = as.character(start(yuimaGUIdata$model[[symb]][[i]]$model at data@original.data)),
- To = as.character(end(yuimaGUIdata$model[[symb]][[i]]$model at data@original.data)),
- AIC = as.character(yuimaGUIdata$model[[symb]][[i]]$aic),
- BIC = as.character(yuimaGUIdata$model[[symb]][[i]]$bic))
- rownames(newRow) <- as.character(paste(symb," ", i, sep=""))
- yuimaGUItable$model <<- rbind(yuimaGUItable$model, newRow)
- }
- }
-})
-
-observeEvent(yuimaGUIdata$simulation, priority = 10, {
- yuimaGUItable$simulation <<- data.frame()
- for (symb in names(yuimaGUIdata$simulation)){
- for (i in 1:length(yuimaGUIdata$simulation[[symb]])){
- newRow <- data.frame(
- "Symb" = as.character(symb),
- "Class" = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$class),
- "Model" = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$model),
- "Jumps" = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$jumps),
- "N sim" = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$nsim),
- "Simulated from" = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$simulate.from),
- "Simulated to" = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$simulate.to),
- "Estimated from" = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$estimate.from),
- "Estimated to" = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$estimate.to),
- check.names = FALSE)
- rownames(newRow) <- as.character(paste(symb," ", i, sep=""))
- yuimaGUItable$simulation <<- rbind(yuimaGUItable$simulation, newRow)
- }
- }
-})
-
-observeEvent(yuimaGUIdata$series, priority = 10, {
- n <- names(yuimaGUIdata$series)
- for (i in names(estimateSettings)) if(!(i %in% n)) estimateSettings[[i]] <<- NULL
- for (i in names(deltaSettings)) if(!(i %in% n)) deltaSettings[[i]] <<- NULL
-})
-
-observeEvent(yuimaGUIdata$hedging, priority = 10, {
- yuimaGUItable$hedging <<- data.frame()
- if (length(yuimaGUIdata$hedging)!=0){
- for (i in 1:length(yuimaGUIdata$hedging)){
- newRow <- data.frame(
- "Symb" = as.character(yuimaGUIdata$hedging[[i]]$symb),
- "Profit (%)" = round(as.numeric(yuimaGUIdata$hedging[[i]]$info$profit*100),2),
- "Std.Err (%)" = round(as.numeric(yuimaGUIdata$hedging[[i]]$info$stdErr*100),2),
- "Option Lots" = as.integer(yuimaGUIdata$hedging[[i]]$info$LotsToBuy),
- "Assets to Buy" = as.integer(yuimaGUIdata$hedging[[i]]$info$buy),
- "Assets to Sell" = as.integer(yuimaGUIdata$hedging[[i]]$info$sell),
- "Asset Price" = as.numeric(yuimaGUIdata$hedging[[i]]$info$assPrice),
- "Option Price" = as.numeric(yuimaGUIdata$hedging[[i]]$info$optPrice),
- "Option Type" = yuimaGUIdata$hedging[[i]]$info$type,
- "Strike" = as.numeric(yuimaGUIdata$hedging[[i]]$info$strike),
- "Maturity" = as.Date(yuimaGUIdata$hedging[[i]]$info$maturity),
- "Model" = as.character(yuimaGUIdata$hedging[[i]]$info$model),
- "Estimated from" = as.Date(yuimaGUIdata$hedging[[i]]$info$estimate.from),
- "Estimated to" = as.Date(yuimaGUIdata$hedging[[i]]$info$estimate.to),
- "AIC" = as.numeric(yuimaGUIdata$hedging[[i]]$aic),
- "BIC" = as.numeric(yuimaGUIdata$hedging[[i]]$bic),
- check.names = FALSE)
- yuimaGUItable$hedging <<- rbind.fill(yuimaGUItable$hedging, newRow)
- }
- }
-})
-
-
-setDataGUI <- function(original.data, delta){
- t <- index(original.data)
- t0 <- 0
- if(is.numeric(t)){
- delta.original.data <- mean(diff(t), na.rm = TRUE)
- t0 <- min(t, na.rm = TRUE)*delta/delta.original.data
- }
- setData(original.data = original.data, delta = delta, t0 = t0)
-}
-
-
-addData <- function(x, typeIndex){
- x <- data.frame(x, check.names = TRUE)
- err <- c()
- alreadyIn <- c()
- for (symb in colnames(x)){
- if (symb %in% names(yuimaGUIdata$series))
- alreadyIn <- c(alreadyIn, symb)
- else{
- temp <- data.frame("Index" = rownames(x), "symb" = as.numeric(as.character(x[,symb])))
- temp <- temp[complete.cases(temp), ]
- rownames(temp) <- temp[,"Index"]
- colnames(temp) <- c("Index", symb)
- if (typeIndex=="numeric"){
- test <- try(read.zoo(temp, FUN=as.numeric, drop = FALSE))
- if (class(test)!="try-error")
- yuimaGUIdata$series[[symb]] <<- test
- else
- err <- c(err, symb)
- }
- else{
- test <- try(read.zoo(temp, FUN=as.Date, format = typeIndex, drop = FALSE))
- if (class(test)!="try-error")
- yuimaGUIdata$series[[symb]] <<- test
- else
- err <- c(err, symb)
- }
- }
- }
- return(list(err = err, already_in = alreadyIn))
-}
-
-getDataNames <- function(){
- return(isolate({yuimaGUItable$series}))
-}
-
-getData <- function(symb){
- return(isolate({yuimaGUIdata$series[[symb]]}))
-}
-
-delData <- function(symb){
- for (i in symb)
- yuimaGUIdata$series <<- yuimaGUIdata$series[-which(names(yuimaGUIdata$series)==i)]
-}
-
-
-defaultModels <- c("Diffusion process"="Geometric Brownian Motion",
- "Diffusion process"="Brownian Motion",
- "Diffusion process"="Ornstein-Uhlenbeck (OU)",
- "Diffusion process"="Vasicek model (VAS)",
- "Diffusion process"="Constant elasticity of variance (CEV)",
- "Diffusion process"= "Cox-Ingersoll-Ross (CIR)",
- "Diffusion process"="Chan-Karolyi-Longstaff-Sanders (CKLS)",
- "Diffusion process"="Hyperbolic (Barndorff-Nielsen)",
- "Diffusion process"="Hyperbolic (Bibby and Sorensen)",
- "Compound Poisson" = "Constant Intensity",
- "Compound Poisson" = "Linear Intensity",
- "Compound Poisson" = "Power Low Intensity",
- "Compound Poisson" = "Exponentially Decaying Intensity",
- "Compound Poisson" = "Periodic Intensity",
- #"Fractional process"="Frac. Geometric Brownian Motion",
- #"Fractional process"="Frac. Brownian Motion",
- "Fractional process"="Frac. Ornstein-Uhlenbeck (OU)",
- "CARMA" = "Carma(p,q)",
- "COGARCH" = "Cogarch(p,q)",
- "Levy process" = "Geometric Brownian Motion with Jumps"
- )
-
-defaultJumps <- c("Gaussian", "Uniform")
-
-defaultBounds <- function(name, delta, strict, jumps = NA, AR_C = NA, MA_C = NA, data, intensity = NULL, threshold = NULL){
- lastPrice = last(data)
- if (name %in% names(isolate({usr_models$model}))){
- par <- setModelByName(name = name, jumps = jumps, AR_C = AR_C, MA_C = MA_C)@parameter at all
- if(strict==TRUE){
- lower <- rep(NA, length(par))
- upper <- rep(NA, length(par))
- } else {
- if (usr_models$model[[name]]$class=="Compound Poisson"){
- lower <- rep(0, length(par))
- upper <- rep(1, length(par))
- } else {
- lower <- rep(-100, length(par))
- upper <- rep(100, length(par))
- }
- }
- names(lower) <- par
- names(upper) <- par
- if (!is.na(jumps)){
- boundsJump <- jumpBounds(jumps = jumps, strict = strict, data = data)
- for (i in par[par %in% names(boundsJump$lower)]){
- lower[[i]] <- boundsJump$lower[[i]]
- upper[[i]] <- boundsJump$upper[[i]]
- }
- }
- return(list(lower=as.list(lower), upper=as.list(upper)))
- }
- if (name %in% defaultModels[names(defaultModels) == "COGARCH"]){
- par <- setModelByName(name = name, jumps = jumps, AR_C = AR_C, MA_C = MA_C)@parameter
- par <- unique(c(par at drift, par at xinit))
- if(strict==TRUE){
- lower <- rep(NA, length(par))
- upper <- rep(NA, length(par))
- } else {
- lower <- rep(0, length(par))
- upper <- rep(10, length(par))
- }
- names(lower) <- par
- names(upper) <- par
- return(list(lower=as.list(lower), upper=as.list(upper)))
- }
- if (name %in% defaultModels[names(defaultModels) == "CARMA"]){
- par <- setModelByName(name = name, jumps = jumps, AR_C = AR_C, MA_C = MA_C)@parameter
- par <- par at drift
- if(strict==TRUE){
- lower <- rep(NA, length(par))
- upper <- rep(NA, length(par))
- names(lower) <- par
- names(upper) <- par
- } else {
- lower <- rep(0, length(par))
- upper <- rep(1, length(par))
- names(lower) <- par
- names(upper) <- par
- lower["MA0"] <- min(lastPrice*0.5, lastPrice*1.5)
- upper["MA0"] <- max(lastPrice*0.5, lastPrice*1.5)
- }
- return(list(lower=as.list(lower), upper=as.list(upper)))
- }
- if (name == "Brownian Motion" | name == "Bm"){
- if (strict==TRUE) return (list(lower=list("sigma"=0, "mu"=NA), upper=list("sigma"=NA, "mu"=NA)))
- else {
- x <- as.numeric(diff(data))
- mu <- mean(x)
- sigma <- sd(x)
- return (list(lower=list("sigma"=sigma/sqrt(delta), "mu"=mu/delta), upper=list("sigma"=sigma/sqrt(delta), "mu"=mu/delta)))
- }
- }
- if (name == "Geometric Brownian Motion" | name == "gBm") {
- if (strict==TRUE) return (list(lower=list("sigma"=0, "mu"=NA), upper=list("sigma"=NA, "mu"=NA)))
- else {
- x <- as.numeric(na.omit(Delt(data)))
- mu <- mean(x)
- sigma <- sd(x)
- return (list(lower=list("sigma"=sigma/sqrt(delta), "mu"=mu/delta), upper=list("sigma"=sigma/sqrt(delta), "mu"=mu/delta)))
- }
- }
- if (name == "Ornstein-Uhlenbeck (OU)" | name == "OU"){
- if (strict==TRUE) return(list(lower=list("theta"=0, "sigma"=0),upper=list("theta"=NA, "sigma"=NA)))
- else return(list(lower=list("theta"=0, "sigma"=0),upper=list("theta"=1/delta, "sigma"=1/sqrt(delta))))
- }
- if (name == "Vasicek model (VAS)" | name == "VAS"){
- if (strict==TRUE) return(list(lower=list("theta3"=0, "theta1"=NA, "theta2"=NA), upper=list("theta3"=NA, "theta1"=NA, "theta2"=NA)))
- else {
- mu <- abs(mean(as.numeric(data), na.rm = TRUE))
- return(list(lower=list("theta3"=0, "theta1"=-0.1*mu/delta, "theta2"=-0.1/delta), upper=list("theta3"=1/sqrt(delta), "theta1"=0.1*mu/delta, "theta2"=0.1/delta)))
- }
- }
- if (name == "Constant elasticity of variance (CEV)" | name == "CEV"){
- if (strict==TRUE) return(list(lower=list("mu"=NA, "sigma"=0, "gamma"=0), upper=list("mu"=NA, "sigma"=NA, "gamma"=NA)))
- else return(list(lower=list("mu"=-1/delta, "sigma"=0, "gamma"=0), upper=list("mu"=1/delta, "sigma"=1/sqrt(delta), "gamma"=3)))
- }
- if (name == "Cox-Ingersoll-Ross (CIR)" | name == "CIR"){
- if (strict==TRUE) return(list(lower=list("theta1"=0,"theta2"=0,"theta3"=0),upper=list("theta1"=NA,"theta2"=NA,"theta3"=NA)))
- else return(list(lower=list("theta1"=0,"theta2"=0,"theta3"=0),upper=list("theta1"=1/delta,"theta2"=1/delta,"theta3"=1/sqrt(delta))))
- }
- if (name == "Chan-Karolyi-Longstaff-Sanders (CKLS)" | name == "CKLS"){
- if (strict==TRUE) return(list(lower=list("theta1"=NA, "theta2"=NA, "theta3"=0, "theta4"=0), upper=list("theta1"=NA, "theta2"=NA, "theta3"=NA, "theta4"=NA)))
- else return(list(lower=list("theta1"=-1/delta, "theta2"=-1/delta, "theta3"=0, "theta4"=0), upper=list("theta1"=1/delta, "theta2"=1/delta, "theta3"=1/sqrt(delta), "theta4"=3)))
- }
- if (name == "Hyperbolic (Barndorff-Nielsen)" | name == "hyp1"){
- if (strict==TRUE) return(list(lower=list("delta"=0, "alpha"=0, "beta"=0, "sigma"=0, "mu"=0), upper=list("delta"=NA, "alpha"=NA, "beta"=NA, "sigma"=NA, "mu"=NA)))
- else return(list(lower=list("delta"=0, "alpha"=0, "beta"=0, "sigma"=0, "mu"=0), upper=list("delta"=100, "alpha"=10, "beta"=10, "sigma"=1/sqrt(delta), "mu"=mean(as.numeric(data), na.rm = TRUE))))
-
- }
- if (name == "Hyperbolic (Bibby and Sorensen)" | name == "hyp2"){
- if (strict==TRUE) return(list(lower=list("delta"=0, "alpha"=0, "beta"=0, "sigma"=0, "mu"=0), upper=list("delta"=NA, "alpha"=NA, "beta"=NA, "sigma"=NA, "mu"=NA)))
- else return(list(lower=list("delta"=0, "alpha"=0, "beta"=0, "sigma"=0, "mu"=0),upper=list("delta"=10, "alpha"=1, "beta"=10, "sigma"=1/sqrt(delta), "mu"=mean(as.numeric(data), na.rm = TRUE))))
- }
- if (name == "Constant Intensity"){
- boundsJump <- jumpBounds(jumps = jumps, strict = strict, data = data)
- if (strict==TRUE) return(list(lower=c(list("lambda"=0), boundsJump$lower),upper=c(list("lambda"=NA), boundsJump$upper)))
- else {
- x <- as.numeric(diff(data))
- counts <- length(x[x!=0 & !is.na(x)])
- lambda <- counts/(length(x)*delta)
- return(list(lower=c(list("lambda"=lambda), boundsJump$lower),upper=c(list("lambda"=lambda), boundsJump$upper)))
- }
- }
- if (name == "Power Low Intensity"){
- boundsJump <- jumpBounds(jumps = jumps, strict = strict, data = data)
- if (strict==TRUE) return(list(lower=c(list("alpha"=0, "beta"=NA), boundsJump$lower),upper=c(list("alpha"=NA, "beta"=NA), boundsJump$upper)))
- else return(list(lower=c(list("alpha"=0, "beta"=-3), boundsJump$lower),upper=c(list("alpha"=0.1/delta^(3/2), "beta"=3), boundsJump$upper)))
- }
- if (name == "Linear Intensity"){
- boundsJump <- jumpBounds(jumps = jumps, strict = strict, data = data)
- if (strict==TRUE) return(list(lower=c(list("alpha"=0, "beta"=0), boundsJump$lower),upper=c(list("alpha"=NA, "beta"=NA), boundsJump$upper)))
- else return(list(lower=c(list("alpha"=0, "beta"=0), boundsJump$lower),upper=c(list("alpha"=1/delta, "beta"=0.1/delta^2), boundsJump$upper)))
- }
- if (name == "Exponentially Decaying Intensity"){
- boundsJump <- jumpBounds(jumps = jumps, strict = strict, data = data)
- if (strict==TRUE) return(list(lower=c(list("alpha"=0, "beta"=0), boundsJump$lower),upper=c(list("alpha"=NA, "beta"=NA), boundsJump$upper)))
- else return(list(lower=c(list("alpha"=0, "beta"=0), boundsJump$lower),upper=c(list("alpha"=1/delta, "beta"=1/delta), boundsJump$upper)))
- }
- if (name == "Periodic Intensity"){
- boundsJump <- jumpBounds(jumps = jumps, strict = strict, data = data)
- if (strict==TRUE) return(list(lower=c(list("a"=0, "b"=0, "omega"=0, "phi"=0), boundsJump$lower),upper=c(list("a"=NA, "b"=NA, "omega"=NA, "phi"=2*pi), boundsJump$upper)))
- else return(list(lower=c(list("a"=0, "b"=0, "omega"=0, "phi"=0), boundsJump$lower),upper=c(list("a"=1/delta, "b"=1/delta, "omega"=1/delta, "phi"=2*pi), boundsJump$upper)))
- }
- if (name == "Geometric Brownian Motion with Jumps"){
- boundsJump <- jumpBounds(jumps = jumps, strict = strict, data = data, threshold = threshold)
- boundsIntensity <- intensityBounds(intensity = intensity, strict = strict, delta = delta)
- if (strict==TRUE) return(list(lower=c(list("mu"=NA, "sigma"=0), boundsJump$lower, boundsIntensity$lower),upper=c(list("mu"=NA, "sigma"=NA), boundsJump$upper, boundsIntensity$upper)))
- else return(list(lower=c(list("mu"=-1, "sigma"=0), boundsJump$lower, boundsIntensity$lower),upper=c(list("mu"=1, "sigma"=1), boundsJump$upper, boundsIntensity$upper)))
- }
-}
-
-
-setThreshold <- function(class, data){
- if(class!="Levy process") return(NA)
- else {
- return(0)
- }
-}
-
-setJumps <- function(jumps){
- if(is.na(jumps)) return("")
- else switch (jumps,
- "Gaussian" = list("dnorm(z, mean = mu_jump, sd = sigma_jump)"),
- "Uniform" = list("dunif(z, min = a_jump, max = b_jump)")
- )
-}
-
-jumpBounds <- function(jumps, data, strict, threshold = 0){
- switch(jumps,
- "Gaussian" = {
- if(strict==TRUE) return(list(lower=list("mu_jump"=NA, "sigma_jump"=0), upper=list("mu_jump"=NA, "sigma_jump"=NA)))
- else {
- x <- na.omit(diff(data))
- x <- x[abs(x)>threshold]
- x <- x-sign(x)*threshold
- mu <- mean(x)
- s <- sd(x)
- return(list(lower=list("mu_jump"=mu, "sigma_jump"=s), upper=list("mu_jump"=mu, "sigma_jump"=s)))
- }
- },
- "Uniform" = {
- if(strict==TRUE) return(list(lower=list("a_jump"=NA, "b_jump"=NA), upper=list("a_jump"=NA, "b_jump"=NA)))
- else {
- x <- na.omit(diff(data))
- x <- x[abs(x)>threshold]
- x <- x-sign(x)*threshold
- a <- min(x)
- b <- max(x)
- return(list(lower=list("a_jump"=a, "b_jump"=b), upper=list("a_jump"=a, "b_jump"=b)))
- }
- }
- )
-}
-
-latexJumps <- function(jumps){
- if (!is.null(jumps)){
- switch (jumps,
- "Gaussian" = "Y_i \\sim N(\\mu_{jump}, \\; \\sigma_{jump})",
- "Uniform" = "Y_i \\sim Unif(a_{jump}, \\; b_{jump})"
- )
- }
-}
-
-intensityBounds <- function(intensity, strict, delta){
- switch(intensity,
- "lambda" = {
- if(strict==TRUE) return(list(lower=list("lambda"=0), upper=list("lambda"=NA)))
- else return(list(lower=list("lambda"=0), upper=list("lambda"=1/delta)))
- }
- )
-}
-
-
-setModelByName <- function(name, jumps = NA, AR_C = NA, MA_C = NA, XinExpr = FALSE, intensity = NA){
- if (name %in% names(isolate({usr_models$model}))){
- if (isolate({usr_models$model[[name]]$class=="Diffusion process" | usr_models$model[[name]]$class=="Fractional process"}))
- return(isolate({usr_models$model[[name]]$object}))
- if (isolate({usr_models$model[[name]]$class=="Compound Poisson"}))
- return(setPoisson(intensity = isolate({usr_models$model[[name]]$intensity}), df = setJumps(jumps = jumps), solve.variable = "x"))
- }
- if (name == "Brownian Motion" | name == "Bm") return(yuima::setModel(drift="mu", diffusion="sigma", solve.variable = "x"))
- if (name == "Geometric Brownian Motion" | name == "gBm") return(yuima::setModel(drift="mu*x", diffusion="sigma*x", solve.variable = "x"))
- if (name == "Ornstein-Uhlenbeck (OU)" | name == "OU") return(yuima::setModel(drift="-theta*x", diffusion="sigma", solve.variable = "x"))
- if (name == "Vasicek model (VAS)" | name == "VAS") return(yuima::setModel(drift="theta1-theta2*x", diffusion="theta3", solve.variable = "x"))
- if (name == "Constant elasticity of variance (CEV)" | name == "CEV") return(yuima::setModel(drift="mu*x", diffusion="sigma*x^gamma", solve.variable = "x"))
- if (name == "Cox-Ingersoll-Ross (CIR)" | name == "CIR") return(yuima::setModel(drift="theta1-theta2*x", diffusion="theta3*sqrt(x)", solve.variable = "x"))
- if (name == "Chan-Karolyi-Longstaff-Sanders (CKLS)" | name == "CKLS") return(yuima::setModel(drift="theta1+theta2*x", diffusion="theta3*x^theta4", solve.variable = "x"))
- if (name == "Hyperbolic (Barndorff-Nielsen)" | name == "hyp1") return(yuima::setModel(drift="(sigma/2)^2*(beta-alpha*((x-mu)/(sqrt(delta^2+(x-mu)^2))))", diffusion="sigma", solve.variable = "x"))
- if (name == "Hyperbolic (Bibby and Sorensen)" | name == "hyp2") return(yuima::setModel(drift="0", diffusion="sigma*exp(0.5*(alpha*sqrt(delta^2+(x-mu)^2)-beta*(x-mu)))", solve.variable = "x"))
- if (name == "Frac. Brownian Motion" | name == "Bm") return(yuima::setModel(drift="mu", diffusion="sigma", solve.variable = "x", hurst = NA))
- if (name == "Frac. Geometric Brownian Motion" | name == "gBm") return(yuima::setModel(drift="mu*x", diffusion="sigma*x", solve.variable = "x", hurst = NA))
- if (name == "Frac. Ornstein-Uhlenbeck (OU)" | name == "OU") return(yuima::setModel(drift="-theta*x", diffusion="sigma", solve.variable = "x", hurst = NA))
- if (name == "Power Low Intensity") return(yuima::setPoisson(intensity="alpha*t^(beta)", df=setJumps(jumps = jumps), solve.variable = "x"))
- if (name == "Constant Intensity") return(yuima::setPoisson(intensity="lambda", df=setJumps(jumps = jumps), solve.variable = "x"))
- if (name == "Linear Intensity") return(yuima::setPoisson(intensity="alpha+beta*t", df=setJumps(jumps = jumps), solve.variable = "x"))
- if (name == "Exponentially Decaying Intensity") return(yuima::setPoisson(intensity="alpha*exp(-beta*t)", df=setJumps(jumps = jumps), solve.variable = "x"))
- if (name == "Periodic Intensity") return(yuima::setPoisson(intensity="a/2*(1+cos(omega*t+phi))+b", df=setJumps(jumps = jumps), solve.variable = "x"))
- if (name == "Cogarch(p,q)") return(yuima::setCogarch(p = MA_C, q = AR_C, measure.type = "CP", measure = list(intensity = "lambda", df = setJumps(jumps = "Gaussian")), XinExpr = XinExpr, Cogarch.var="y", V.var="v", Latent.var="x", ma.par="MA", ar.par="AR"))
- if (name == "Carma(p,q)") return(yuima::setCarma(p = AR_C, q = MA_C, ma.par="MA", ar.par="AR", XinExpr = XinExpr))
- if (name == "Geometric Brownian Motion with Jumps") {
- if(intensity=="None") return(yuima::setModel(drift="mu*x", diffusion="sigma*x", jump.coeff="x", measure.type = "code", measure = list(df = setJumps(jumps = jumps)), solve.variable = "x"))
- else return(yuima::setModel(drift="mu*x", diffusion="sigma*x", jump.coeff="x", measure.type = "CP", measure = list(intensity = intensity, df = setJumps(jumps = jumps)), solve.variable = "x"))
- }
-}
-
-printModelLatex <- function(names, process, jumps = NA){
- if (process=="Diffusion process"){
- mod <- ""
- for (name in names){
- if (name %in% names(isolate({usr_models$model}))){
- text <- toLatex(setModelByName(name))
- x <- paste(text[2:9], collapse = "")
- x <- substr(x,3,nchar(x))
- x <- gsub(x, pattern = "'", replacement = "")
- x <- gsub(x, pattern = "x", replacement = "X_t")
- x <- gsub(x, pattern = "W1", replacement = "W_t")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), x)
- }
- if (name == "Brownian Motion" | name == "Bm")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = \\mu \\; dt + \\sigma \\; dW_t")
- if (name == "Geometric Brownian Motion" | name == "gBm")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = \\mu X_t \\; dt + \\sigma X_t \\; dW_t")
- if (name == "Ornstein-Uhlenbeck (OU)" | name == "OU")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = -\\theta X_t \\; dt + \\sigma \\; dW_t")
- if (name == "Vasicek model (VAS)" | name == "VAS")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = (\\theta_1 - \\theta_2 X_t) \\;dt + \\theta_3 \\; dW_t")
- if (name == "Constant elasticity of variance (CEV)" | name == "CEV")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = \\mu X_t \\;dt + \\sigma X_t^\\gamma \\; dW_t")
- if (name == "Cox-Ingersoll-Ross (CIR)" | name == "CIR")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = (\\theta_1-\\theta_2 X_t) \\; dt + \\theta_3 \\sqrt{X_t} \\; dW_t")
- if (name == "Chan-Karolyi-Longstaff-Sanders (CKLS)" | name == "CKLS")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = (\\theta_1+\\theta_2 X_t) \\; dt + \\theta_3 X_t^{\\theta_4} \\; dW_t")
- if (name == "Hyperbolic (Barndorff-Nielsen)" | name == "hyp1")
- mod <- paste(mod, ifelse(mod=="","","\\\\"),"dX_t = \\frac{\\sigma}{2}^2 \\Bigl (\\beta-\\alpha \\frac{X_t-\\mu}{\\sqrt{\\delta^2+(X_t-\\mu)^2}} \\Bigl ) \\; dt + \\sigma \\; dW_t")
- if (name == "Hyperbolic (Bibby and Sorensen)" | name == "hyp2")
- mod <- paste(mod, ifelse(mod=="","","\\\\"),"dX_t = \\sigma \\; exp\\Bigl[\\frac{1}{2} \\Bigl( \\alpha \\sqrt{\\delta^2+(X_t-\\mu)^2}-\\beta (X_t-\\mu)\\Bigl)\\Bigl] \\; dW_t")
- }
- return(paste("$$",mod,"$$"))
- }
- if (process=="Fractional process"){
- mod <- ""
- for (name in names){
- if (name %in% names(isolate({usr_models$model}))){
- text <- toLatex(setModelByName(name))
- x <- paste(text[2:9], collapse = "")
- x <- substr(x,3,nchar(x))
- x <- gsub(x, pattern = "'", replacement = "")
- x <- gsub(x, pattern = "x", replacement = "X_t")
- x <- gsub(x, pattern = "W1", replacement = "W_t^H")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), x)
- }
- if (name == "Frac. Brownian Motion" | name == "Bm")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = \\mu \\; dt + \\sigma \\; dW_t^H")
- if (name == "Frac. Geometric Brownian Motion" | name == "gBm")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = \\mu X_t \\; dt + \\sigma X_t \\; dW_t^H")
- if (name == "Frac. Ornstein-Uhlenbeck (OU)" | name == "OU")
- mod <- paste(mod, ifelse(mod=="","","\\\\"), "dX_t = -\\theta X_t \\; dt + \\sigma \\; dW_t^H")
- }
- return(paste("$$",mod,"$$"))
- }
- if (process=="Compound Poisson"){
- mod <- paste("X_t = X_0+\\sum_{i=0}^{N_t} Y_i \\; : \\;\\;\\; N_t \\sim Poi\\Bigl(\\int_0^t \\lambda(t)dt\\Bigl)", ifelse(!is.null(jumps), paste(", \\;\\;\\;\\; ", latexJumps(jumps)),""))
- for (name in names){
- if (name %in% names(isolate({usr_models$model}))){
- text <- paste("\\lambda(t)=",usr_models$model[[name]]$intensity)
- mod <- paste(mod, ifelse(mod=="","","\\\\"), text)
- }
- if (name == "Power Low Intensity") mod <- paste(mod, ifelse(mod=="","","\\\\"), "\\lambda(t)=\\alpha \\; t^{\\beta}")
- if (name == "Constant Intensity") mod <- paste(mod, ifelse(mod=="","","\\\\"), "\\lambda(t)=\\lambda")
- if (name == "Linear Intensity") mod <- paste(mod, ifelse(mod=="","","\\\\"), "\\lambda(t)=\\alpha+\\beta \\; t")
- if (name == "Exponentially Decaying Intensity") mod <- paste(mod, ifelse(mod=="","","\\\\"), "\\lambda(t)=\\alpha \\; e^{-\\beta t}")
- if (name == "Periodic Intensity") mod <- paste(mod, ifelse(mod=="","","\\\\"), "\\lambda(t)=\\frac{a}{2}\\bigl(1+cos(\\omega t + \\phi)\\bigl)+b")
- }
- return(paste("$$",mod,"$$"))
- }
- if (process=="COGARCH"){
- return(paste("$$","COGARCH(p,q)","$$"))
- }
- if (process=="CARMA"){
- return(paste("$$","CARMA(p,q)","$$"))
- }
- if (process=="Levy process"){
- return(paste("$$","dX_t = \\mu X_t \\; dt + \\sigma X_t \\; dW_t + X_t \\; dZ_t","$$"))
- }
-}
-
-
-###Function to convert unit of measure of the estimates
-changeBaseP <- function(param, StdErr, delta, original.data, paramName, modelName, newBase, allParam){
- msg <- NULL
- if (newBase == "delta")
- return(list("Estimate"= param, "Std. Error"=StdErr, "msg"=msg))
- if(class(index(original.data))=="Date"){
- seriesLength <- as.numeric(difftime(end(original.data),start(original.data)),units="days")
- if (newBase == "Yearly") dt1 <- seriesLength/365/(length(original.data)-1)
- if (newBase == "Semestral") dt1 <- seriesLength/182.50/(length(original.data)-1)
- if (newBase == "Quarterly") dt1 <- seriesLength/120/(length(original.data)-1)
- if (newBase == "Trimestral") dt1 <- seriesLength/90/(length(original.data)-1)
- if (newBase == "Bimestral") dt1 <- seriesLength/60/(length(original.data)-1)
- if (newBase == "Monthly") dt1 <- seriesLength/30/(length(original.data)-1)
- if (newBase == "Weekly") dt1 <- seriesLength/7/(length(original.data)-1)
- if (newBase == "Daily") dt1 <- seriesLength/(length(original.data)-1)
- }
- if(class(index(original.data))=="numeric"){
- dt1 <- as.numeric(end(original.data) - start(original.data))/(length(original.data)-1)
- msg <- "Parameters are in the same unit of measure of input data"
- }
- if (modelName %in% c("Brownian Motion","Bm","Geometric Brownian Motion","gBm")){
- if(paramName == "mu") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "sigma") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1), "msg"=msg))
- }
- if (modelName %in% c("Ornstein-Uhlenbeck (OU)","OU")){
- if(paramName == "theta") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "sigma") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1), "msg"=msg))
- }
- if (modelName %in% c("Vasicek model (VAS)","VAS")){
- if(paramName == "theta1") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "theta2") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "theta3") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1), "msg"=msg))
- }
- if (modelName %in% c("Constant elasticity of variance (CEV)","CEV")){
- if(paramName == "mu") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "sigma") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1), "msg"=msg))
- if(paramName == "gamma") return(list("Estimate"= param, "Std. Error"=StdErr, "msg"=msg))
- }
- if (modelName %in% c("Cox-Ingersoll-Ross (CIR)","CIR")){
- if(paramName == "theta1") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "theta2") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "theta3") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1), "msg"=msg))
- }
- if (modelName %in% c("Chan-Karolyi-Longstaff-Sanders (CKLS)","CKLS")){
- if(paramName == "theta1") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "theta2") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1, "msg"=msg))
- if(paramName == "theta3") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1), "msg"=msg))
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/yuima -r 531
More information about the Yuima-commits
mailing list