[Yuima-commits] r418 - in pkg/yuimaGUI: . R inst inst/yuimaGUI inst/yuimaGUI/www
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Wed Mar 16 21:31:34 CET 2016
Author: phoenix844
Date: 2016-03-16 21:31:34 +0100 (Wed, 16 Mar 2016)
New Revision: 418
Added:
pkg/yuimaGUI/inst/yuimaGUI/
pkg/yuimaGUI/inst/yuimaGUI/global.R
pkg/yuimaGUI/inst/yuimaGUI/server.R
pkg/yuimaGUI/inst/yuimaGUI/ui.R
pkg/yuimaGUI/inst/yuimaGUI/www/
pkg/yuimaGUI/inst/yuimaGUI/www/custom.css
pkg/yuimaGUI/inst/yuimaGUI/www/example.jpg
Modified:
pkg/yuimaGUI/DESCRIPTION
pkg/yuimaGUI/NAMESPACE
pkg/yuimaGUI/R/sourceCodeYuimaGUI.R
Log:
Added density over histogram and mean computation
Modified: pkg/yuimaGUI/DESCRIPTION
===================================================================
--- pkg/yuimaGUI/DESCRIPTION 2016-03-16 14:19:50 UTC (rev 417)
+++ pkg/yuimaGUI/DESCRIPTION 2016-03-16 20:31:34 UTC (rev 418)
@@ -1,10 +1,9 @@
Package: yuimaGUI
Type: Package
Title: A Graphical User Interface for the Yuima Package
-Version: 0.4.2
+Version: 0.4.3
Author: YUIMA Project Team
Maintainer: Emanuele Guidotti <emanuele.guidotti at studenti.unimi.it>
-Description: The package provides a graphical user interface for the yuima package.
+Description: Provides a graphical user interface for the yuima package.
License: GPL-2
-Depends: R(>= 3.0.0), shiny, DT, shinydashboard, shinyBS,
- yuima, quantmod, shinyjs
+Depends: R(>= 3.0.0), shiny, DT, shinydashboard, shinyBS, yuima, quantmod, shinyjs
Modified: pkg/yuimaGUI/NAMESPACE
===================================================================
--- pkg/yuimaGUI/NAMESPACE 2016-03-16 14:19:50 UTC (rev 417)
+++ pkg/yuimaGUI/NAMESPACE 2016-03-16 20:31:34 UTC (rev 418)
@@ -1,9 +1,9 @@
#exportPattern("^[[:alpha:]]+")
export(yuimaGUI)
-importFrom(shiny, runApp)
+import("shiny")
import("shinyBS")
-importFrom("quantmod",getSymbols)
+importFrom("quantmod",getSymbols, Delt)
import("DT")
import("shinyjs")
import("yuima")
Modified: pkg/yuimaGUI/R/sourceCodeYuimaGUI.R
===================================================================
--- pkg/yuimaGUI/R/sourceCodeYuimaGUI.R 2016-03-16 14:19:50 UTC (rev 417)
+++ pkg/yuimaGUI/R/sourceCodeYuimaGUI.R 2016-03-16 20:31:34 UTC (rev 418)
@@ -1,7 +1,7 @@
yuimaGUI <- function() {
shiny::runApp(
system.file(
- "yuimaGUI_v0.4.1",
+ "yuimaGUI",
package = "yuimaGUI"
)
)
Added: pkg/yuimaGUI/inst/yuimaGUI/global.R
===================================================================
--- pkg/yuimaGUI/inst/yuimaGUI/global.R (rev 0)
+++ pkg/yuimaGUI/inst/yuimaGUI/global.R 2016-03-16 20:31:34 UTC (rev 418)
@@ -0,0 +1,525 @@
+require(shiny)
+require(DT)
+require(quantmod)
+require(shinydashboard)
+require(shinyBS)
+require(yuima)
+require(shinyjs)
+
+
+if(!exists("yuimaGUItable"))
+ yuimaGUItable <<- reactiveValues(series=data.frame(), model=data.frame(), simulation=data.frame())
+
+if(!exists("yuimaGUIdata"))
+ yuimaGUIdata <<- reactiveValues(series=list(), model=list(), simulation=list())
+
+if(!exists("estimateSettings"))
+ estimateSettings <<- list()
+
+if(!exists("deltaSettings"))
+ deltaSettings <<- list()
+
+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))
+}
+
+
+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),
+ Model = as.character(yuimaGUIdata$model[[symb]][[i]]$info$modName),
+ 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),
+ Model = as.character(yuimaGUIdata$simulation[[symb]][[i]]$info$model),
+ "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))
+ rownames(newRow) <- as.character(paste(symb," ", i, sep=""))
+ yuimaGUItable$simulation <<- rbind(yuimaGUItable$simulation, newRow)
+ }
+ }
+})
+
+addData <- function(x, typeIndex, session, anchorId, printSuccess = TRUE){
+ x <- data.frame(x, check.names = FALSE)
+ 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"]
+ if (typeIndex=="numeric"){
+ test <- try(read.zoo(temp, FUN=as.numeric))
+ 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))
+ if (class(test)!="try-error")
+ yuimaGUIdata$series[[symb]] <<- test
+ else
+ err <- c(err, symb)
+ }
+ }
+ }
+ if (length(err)==0 & length(alreadyIn)==0 & printSuccess)
+ createAlert(session = session, anchorId = anchorId, content = paste("Data uploaded successfully"), style = "success")
+ if (length(err)!=0)
+ createAlert(session = session, anchorId = anchorId, content = paste("Unable to upload following symbols:",paste(err,collapse = " ")), style = "error")
+ if (length(alreadyIn)!=0)
+ createAlert(session = session, anchorId = anchorId, content = paste("Following data already uploaded:", paste(alreadyIn, collapse = " ")), style = "warning")
+}
+
+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"="Brownian Motion",
+ "Diffusion process"="Geometric 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)")
+
+defaultStart <- function(name, default = 1000){
+ if (name %in% names(isolate({usr_models$model}))){
+ par <- setModelByName(name)@parameter at all
+ startmin <- rep(-default, length(par))
+ startmax <- rep(default, length(par))
+ names(startmin) <- par
+ names(startmax) <- par
+ return(list(min=as.list(startmin), max=as.list(startmax)))
+ }
+ if (name == "Brownian Motion" | name == "Bm")
+ return (list(min=list("sigma"=0, "mu"=-default), max=list("sigma"=default, "mu"=default)))
+ if (name == "Geometric Brownian Motion" | name == "gBm")
+ return (list(min=list("sigma"=0, "mu"=-default), max=list("sigma"=default, "mu"=default)))
+ if (name == "Ornstein-Uhlenbeck (OU)" | name == "OU")
+ return(list(min=list("theta"=-default),max=list("theta"=default)))
+ if (name == "Vasicek model (VAS)" | name == "VAS")
+ return(list(min=list("theta3"=0, "theta1"=-default, "theta2"=-default),max=list("theta3"=default, "theta1"=default, "theta2"=default)))
+ if (name == "Constant elasticity of variance (CEV)" | name == "CEV")
+ return(list(min=list("mu"=-default, "sigma"=-default, "gamma"=-3),max=list("mu"=default, "sigma"=default, "gamma"=3)))
+ if (name == "Cox-Ingersoll-Ross (CIR)" | name == "CIR")
+ return(list(min=list("theta1"=0,"theta2"=0,"theta3"=0),max=list("theta1"=default,"theta2"=default,"theta3"=default)))
+ if (name == "Chan-Karolyi-Longstaff-Sanders (CKLS)" | name == "CKLS")
+ return(list(min=list("theta1"=-default, "theta2"=-default, "theta3"=0, "theta4"=-3),max=list("theta1"=default, "theta2"=default, "theta3"=default, "theta4"=3)))
+ if (name == "Hyperbolic (Barndorff-Nielsen)" | name == "hyp1")
+ return(list(min=list("delta"=0, "alpha"=0, "beta"=0, "sigma"=-default, "mu"=-default),max=list("delta"=default, "alpha"=default, "beta"=default, "sigma"=default, "mu"=default)))
+ if (name == "Hyperbolic (Bibby and Sorensen)" | name == "hyp2")
+ return(list(min=list("delta"=0, "alpha"=0, "beta"=0, "sigma"=-default, "mu"=-default),max=list("delta"=default, "alpha"=default, "beta"=default, "sigma"=default, "mu"=default)))
+}
+
+
+defaultBounds <- function(name){
+ if (name %in% names(isolate({usr_models$model})))
+ return(list(lower=list(),upper=list()))
+ if (name == "Brownian Motion" | name == "Bm")
+ return (list(lower=list("sigma"=0), upper=list()))
+ if (name == "Geometric Brownian Motion" | name == "gBm")
+ return(list(lower=list("sigma"=0),upper=list()))
+ if (name == "Ornstein-Uhlenbeck (OU)" | name == "OU")
+ return(list(lower=list(),upper=list()))
+ if (name == "Vasicek model (VAS)" | name == "VAS")
+ return(list(lower=list("theta3"=0),upper=list()))
+ if (name == "Constant elasticity of variance (CEV)" | name == "CEV")
+ return(list(lower=list(),upper=list()))
+ if (name == "Cox-Ingersoll-Ross (CIR)" | name == "CIR")
+ return(list(lower=list("theta1"=0,"theta2"=0,"theta3"=0),upper=list()))
+ if (name == "Chan-Karolyi-Longstaff-Sanders (CKLS)" | name == "CKLS")
+ return(list(lower=list("theta3"=0),upper=list()))
+ if (name == "Hyperbolic (Barndorff-Nielsen)" | name == "hyp1")
+ return(list(lower=list("delta"=0, "alpha"=0, "beta"=0),upper=list()))
+ if (name == "Hyperbolic (Bibby and Sorensen)" | name == "hyp2")
+ return(list(lower=list("delta"=0, "alpha"=0, "beta"=0),upper=list()))
+}
+
+
+setModelByName <- function(name){
+ if (name %in% names(isolate({usr_models$model})))
+ return(isolate({usr_models$model[[name]]$object}))
+ 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="1", 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"))
+}
+
+printModelLatex <- function(names){
+ mod <- ""
+ for (name in names){
+ if (name %in% names(isolate({usr_models$model}))){
+ if (isolate({usr_models$model[[name]]$class=="Diffusion process"})){
+ 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 + \\; 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,"$$"))
+}
+
+
+###Function to convert unit of measure of the estimates
+changeBase <- function(param, StdErr, delta, original.data, paramName, modelName, newBase, session, choicesUI, anchorId, alertId){
+ if (newBase == "delta")
+ return(list("Estimate"= param, "Std. Error"=StdErr))
+ if(class(index(original.data))=="Date"){
+ shinyjs::show(choicesUI)
+ closeAlert(session, alertId = alertId)
+ 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"){
+ shinyjs::hide(choicesUI)
+ dt1 <- as.numeric(end(original.data) - start(original.data))/(length(original.data)-1)
+ closeAlert(session, alertId)
+ createAlert(session = session, anchorId = anchorId, alertId = alertId, content = "Parameters are in the same unit of measure of input data", style = "info")
+ }
+ 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))
+ if(paramName == "sigma") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1)))
+ }
+ if (modelName %in% c("Ornstein-Uhlenbeck (OU)","OU")){
+ if(paramName == "theta") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1))
+ }
+ if (modelName %in% c("Vasicek model (VAS)","VAS")){
+ if(paramName == "theta1") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1))
+ if(paramName == "theta2") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1))
+ if(paramName == "theta3") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1)))
+ }
+ if (modelName %in% c("Constant elasticity of variance (CEV)","CEV")){
+ if(paramName == "mu") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1))
+ if(paramName == "sigma") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1)))
+ if(paramName == "gamma") return(list("Estimate"= param, "Std. Error"=StdErr))
+ }
+ if (modelName %in% c("Cox-Ingersoll-Ross (CIR)","CIR")){
+ if(paramName == "theta1") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1))
+ if(paramName == "theta2") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1))
+ if(paramName == "theta3") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1)))
+ }
+ if (modelName %in% c("Chan-Karolyi-Longstaff-Sanders (CKLS)","CKLS")){
+ if(paramName == "theta1") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1))
+ if(paramName == "theta2") return(list("Estimate"= param*delta/dt1, "Std. Error"=StdErr*delta/dt1))
+ if(paramName == "theta3") return(list("Estimate"= param*sqrt(delta/dt1), "Std. Error"=StdErr*sqrt(delta/dt1)))
+ if(paramName == "theta4") return(list("Estimate"= param, "Std. Error"=StdErr))
+ }
+ closeAlert(session, alertId)
+ createAlert(session = session, anchorId = anchorId, alertId = alertId, content = paste("No parameters conversion available for this model. Parameters have been obtained using delta = ", delta), style = "warning")
+ shinyjs::hide(choicesUI)
+ return(list("Estimate"= param, "Std. Error"=StdErr))
+}
+
+
+addModel <- function(modName, symbName, data, delta, start, startMin, startMax, tries, seed, method="BFGS", fixed = list(), lower, upper, joint=FALSE, aggregation=TRUE, threshold=NULL, session, anchorId, alertId){
+ info <- list(
+ modName = modName,
+ method=method,
+ delta = delta,
+ start = start,
+ startMin = startMin,
+ startMax = startMax,
+ tries = tries,
+ seed = seed,
+ fixed = fixed,
+ lower = lower,
+ upper = upper,
+ joint = joint,
+ aggregation = aggregation,
+ threshold = threshold
+ )
+ clearNA <- function(List){
+ for (i in names(List))
+ if (is.na(List[[i]]))
+ List[[i]] <- NULL
+ return (List)
+ }
+ if(!is.na(seed)) set.seed(seed)
+ if(is.na(seed)) set.seed(NULL)
+ start <- clearNA(start)
+ fixed <- clearNA(fixed)
+ lower <- clearNA(lower)
+ upper <- clearNA(upper)
+ model <- setYuima(data = setData(data, delta = delta), model=setModelByName(name = modName))
+ parameters <- setModelByName(modName)@parameter
+ if (all(parameters at all %in% c(names(start),names(fixed)))){
+ QMLE <- try(qmle(model, start = start, fixed = fixed, method = method, lower = lower, upper = upper, #joint = joint, aggregation = aggregation,
+ threshold = threshold))
+ if (class(QMLE)=="try-error"){
+ createAlert(session = session, anchorId = anchorId, alertId = alertId, content = paste("Unable to estimate", modName,"on", symbName), style = "danger")
+ return()
+ }
+ }
+ else{
+ if (modName == "Geometric Brownian Motion" | modName == "gBm"){
+ X <- as.numeric(na.omit(Delt(data, type = "log")))
+ alpha <- mean(X)/delta
+ sigma <- sqrt(var(X)/delta)
+ mu <- alpha +0.5*sigma^2
+ if (is.null(start$sigma)) start$sigma <- sigma
+ if (is.null(start$mu)) start$mu <- mu
+ QMLE <- try(qmle(model, start = start, fixed = fixed, method = method, lower = lower, upper = upper, #joint = joint, aggregation = aggregation,
+ threshold = threshold))
+ if (class(QMLE)=="try-error"){
+ createAlert(session = session, anchorId = anchorId, alertId = alertId, content = paste("Unable to estimate", modName,"on", symbName), style = "danger")
+ return()
+ }
+ #} else if (modName == "Brownian Motion" | modName == "Bm") {
+ #Delta <- ifelse(is.null(delta), 1, delta)
+ #X <- as.numeric(na.omit(Delt(data, type = "arithmetic")))
+ #mu <- mean(X)/Delta
+ #sigma <- sqrt(var(X)/Delta)
+ #if (is.null(start$sigma)) start$sigma <- sigma
+ #if (is.null(start$mu)) start$mu <- mu
+ #QMLE <- qmle(model, start = start, fixed = fixed, method = method, lower = lower, upper = upper, #joint = joint, aggregation = aggregation,
+ # threshold = threshold)
+ } else {
+ miss <- parameters at all[!(parameters at all %in% c(names(start),names(fixed)))]
+ m2logL_prec <- NA
+ na_prec <- NA
+ withProgress(message = 'Step: ', value = 0, {
+ for(iter in 1:tries){
+ incProgress(1/tries, detail = paste(iter,"(/", tries ,")"))
+ repeat{
+ for (i in miss)
+ start[[i]] <- runif(1, min = max(lower[[i]],ifelse(is.null(startMin[[i]]),-10,startMin[[i]])), max = min(upper[[i]],ifelse(is.null(startMax[[i]]), 10, startMax[[i]])))
+ QMLEtemp <- try(qmle(model, start = start, fixed = fixed, method = method, lower = lower, upper = upper, #joint = joint, aggregation = aggregation,
+ threshold = threshold))
+ if (class(QMLEtemp)!="try-error")
+ break
+ }
+ repeat{
+ m2logL <- summary(QMLEtemp)@m2logL
+ coefTable <- summary(QMLEtemp)@coef
+ for (param in names(start))
+ start[[param]] <- as.numeric(coefTable[param,"Estimate"])
+ QMLEtemp <- try(qmle(model, start = start, fixed = fixed, method = method, lower = lower, upper = upper, #joint = joint, aggregation = aggregation,
+ threshold = threshold))
+ if (class(QMLEtemp)=="try-error")
+ break
+ else if (summary(QMLEtemp)@m2logL>=0.999*m2logL)
+ break
+ }
+ if(is.na(m2logL_prec & class(QMLEtemp)!="try-error")){
+ QMLE <- QMLEtemp
+ m2logL_prec <- summary(QMLE)@m2logL
+ na_prec <- sum(is.na(coefTable))
+ }
+ else if (class(QMLEtemp)!="try-error"){
+ if (sum(is.na(coefTable)) < na_prec){
+ QMLE <- QMLEtemp
+ m2logL_prec <- summary(QMLE)@m2logL
+ na_prec <- sum(is.na(coefTable))
+ }
+ else if(summary(QMLEtemp)@m2logL < m2logL_prec & sum(is.na(coefTable))==na_prec){
+ QMLE <- QMLEtemp
+ m2logL_prec <- summary(QMLE)@m2logL
+ na_prec <- sum(is.na(coefTable))
+ }
+ }
+ }
+ })
+ }
+ }
+ yuimaGUIdata$model[[symbName]][[ifelse(is.null(length(yuimaGUIdata$model[[symbName]])),1,length(yuimaGUIdata$model[[symbName]])+1)]] <<- list(
+ model = model,
+ qmle = QMLE,
+ aic = AIC(QMLE),
+ bic = BIC(QMLE),
+ info = info
+ )
+}
+
+
+
+
+
+getModelNames <- function(){
+ return(isolate({yuimaGUItable$model}))
+}
+
+getModel <- function(symb){
+ return(isolate({yuimaGUIdata$model[[symb]]}))
+}
+
+delModel <- function(symb, n=1){
+ for(i in length(symb):1){
+ yuimaGUIdata$model[[symb[i]]][as.numeric(n[i])] <<- NULL
+ if (length(yuimaGUIdata$model[[symb[i]]])==0)
+ yuimaGUIdata$model[[symb[i]]] <<- NULL
+ }
+}
+
+
+
+addSimulation <- function(model, symbName, info = list("simulate.from"=NA, "simulate.to"=NA,"model"=NA, "estimate.from"=NA, "estimate.to"=NA), xinit, true.parameter, nsim, saveTraj = TRUE, seed=NULL, sampling, subsampling = NULL, space.discretized = FALSE, method = "euler", session, anchorId){
+ if(!is.na(seed)) set.seed(seed)
+ if(is.na(seed)) set.seed(NULL)
+ if(saveTraj==TRUE){
+ trajectory <- zoo::zoo(order.by = numeric())
+ hist <- NA
+ }
+ if(saveTraj==FALSE){
+ trajectory <- NA
+ hist <- vector()
+ }
+ is.valid <- TRUE
+ withProgress(message = 'Simulating: ', value = 0, {
+ for (i in 1:nsim){
+ incProgress(1/nsim, detail = paste("Simulating:",i,"(/",nsim,")"))
+ if(is.null(subsampling))
+ simulation <- try(yuima::simulate(object = model, xinit = xinit, true.parameter = true.parameter, nsim = nsim, sampling = sampling, space.discretized = space.discretized, method = method))
+ else
+ simulation <- try(yuima::simulate(object = model, xinit = xinit, true.parameter = true.parameter, nsim = nsim, sampling = sampling, subsampling = subsampling, space.discretized = space.discretized, method = method))
+ if (class(simulation)=="try-error"){
+ is.valid <- FALSE
+ break()
+ }
+ if(is.valid){
+ if (saveTraj==TRUE)
+ trajectory <- merge(trajectory, simulation at data@zoo.data[[1]])
+ else
+ hist <- c(hist, as.numeric(tail(simulation at data@zoo.data[[1]],1)))
+ }
+ }
+ })
+ if (!is.valid){
+ createAlert(session = session, anchorId = anchorId, content = paste("Unable to simulate", symbName,"by", info$model), style = "danger")
+ return()
+ }
+
+ if(saveTraj==TRUE){
+ if(class(info$simulate.from)=="Date")
+ index(trajectory) <- as.POSIXlt(24*60*60*index(trajectory)/simulation at sampling@delta*as.numeric(info$simulate.to-info$simulate.from)/(simulation at sampling@n), origin = info$simulate.from)
+ if(class(info$simulate.from)=="numeric")
+ index(trajectory) <- as.numeric(index(trajectory)/simulation at sampling@delta*as.numeric(info$simulate.to-info$simulate.from)/(simulation at sampling@n))
+ if(!is.null(colnames(trajectory)))
+ colnames(trajectory) <- seq(1:length(colnames(trajectory)))
+ }
+
+ info$nsim <- nsim
+ yuimaGUIdata$simulation[[symbName]][[ifelse(is.null(length(yuimaGUIdata$simulation[[symbName]])),1,length(yuimaGUIdata$simulation[[symbName]])+1)]] <<- list(
+ trajectory = trajectory,
+ hist = hist,
+ true.parameter = true.parameter,
+ info = info
+ )
+}
+
+delSimulation <- function(symb, n=1){
+ for(i in length(symb):1){
+ yuimaGUIdata$simulation[[symb[i]]][as.numeric(n[i])] <<- NULL
+ if (length(yuimaGUIdata$simulation[[symb[i]]])==0)
+ yuimaGUIdata$simulation[[symb[i]]] <<- NULL
+ }
+}
+
+
Added: pkg/yuimaGUI/inst/yuimaGUI/server.R
===================================================================
--- pkg/yuimaGUI/inst/yuimaGUI/server.R (rev 0)
+++ pkg/yuimaGUI/inst/yuimaGUI/server.R 2016-03-16 20:31:34 UTC (rev 418)
@@ -0,0 +1,1481 @@
+options(shiny.maxRequestSize = 9*1024^2)
+
+
+server <- function(input, output, session) {
+
+ ###Save all available data
+ saveData <- function() {
+ dataDownload_series <- reactive({
+ data <- data.frame()
+ for (symb in names(yuimaGUIdata$series))
+ data <- as.data.frame(rbind.fill(as.data.frame(data),as.data.frame(t(getData(symb)))))
+ data <- as.data.frame(t(data))
+ colnames(data) <- names(yuimaGUIdata$series)
+ return(data)
+ })
+ downloadHandler(
+ filename = "yuimaGUIdata.txt",
+ content = function(file) {
+ write.table(dataDownload_series(), file, quote = FALSE)
+ }
+ )
+ }
+
+ ########################Load Economic and Financial Data
+ ########################
+ ########################
+
+
+ ###Download data and display message
+ observeEvent(input$finDataGo, priority = 1, {
+ if (input$symb!=""){
+ closeAlert(session, "finDataAlert_err")
+ closeAlert(session, "finDataAlert_succ")
+ symb <- unlist(strsplit(input$symb, split = "[, ]+" , fixed = FALSE))
+ err <- c()
+ withProgress(message = 'Loading: ', value = 0, {
+ for (i in symb){
+ incProgress(1/length(symb), detail = i)
+ x <- try(getSymbols(i, src = input$sources ,auto.assign = FALSE, from = input$dR[1], to = input$dR[2]))
+ if (class(x)[1]=="try-error")
+ err <- cbind(err,i)
+ else
+ addData(x, typeIndex = "%Y-%m-%d", session = session, anchorId = "finDataAlert", printSuccess = FALSE)
+ }
+ })
+ if(!is.null(err))
+ createAlert(session = session, anchorId = "finDataAlert", alertId = "finDataAlert_err", content = paste("WARNING! Unable to download following symbols:", paste(err,collapse = " ")), style = "danger")
+ if(is.null(err))
+ createAlert(session = session, anchorId = "finDataAlert", alertId = "finDataAlert_succ", content = paste("All symbols downloaded successfully"), style = "success")
+ }
+ })
+
+ ###Display available data
+ output$database1 <- DT::renderDataTable(options=list(scrollY = 200, scrollCollapse = TRUE, deferRender = TRUE, dom = 'frtiS'), extensions = 'Scroller', selection = "multiple", rownames = FALSE,{
+ if (length(yuimaGUItable$series)==0){
+ NoData <- data.frame("Symb"=NA,"From"=NA, "To"=NA)
+ return(NoData[-1,])
+ }
+ return(yuimaGUItable$series)
+ })
+
+ ###Interactive range of finDataPlot chart
+ range_finDataPlot <- reactiveValues(x=NULL, y=NULL)
+ observe({
+ if (!is.null(input$finDataPlot_brush)){
+ range_finDataPlot$x <- c(as.Date(input$finDataPlot_brush$xmin), as.Date(input$finDataPlot_brush$xmax))
+ range_finDataPlot$y <- c(input$finDataPlot_brush$ymin, input$finDataPlot_brush$ymax)
+ }
+ })
+ observeEvent(input$finDataPlot_dbclick,{
+ range_finDataPlot$x <- c(NULL, NULL)
+ range_finDataPlot$y <- c(NULL, NULL)
+ })
+
+ ###Display chart of last clicked symbol
+ observeEvent(input$database1_rows_selected, priority = -1, {
+ range_finDataPlot$x <- NULL
+ range_finDataPlot$y <- NULL
+ symb <- tail(input$database1_rows_selected,1)
+ shinyjs::show("finDataPlot")
+ shinyjs::show("scale_finDataPlot")
+ output$finDataPlot <- renderPlot({
+ if (length(yuimaGUItable$series)==0){
+ shinyjs::hide("finDataPlot")
+ shinyjs::hide("scale_finDataPlot")
+ }
+ else{
+ if (!(symb %in% as.character(yuimaGUItable$series[,"Symb"]))){
+ shinyjs::hide("finDataPlot")
+ shinyjs::hide("scale_finDataPlot")
+ }
+ else {
+ par(bg="black")
+ plot.zoo(window(getData(symb), start = range_finDataPlot$x[1], end = range_finDataPlot$x[2]), main=symb, log=ifelse(input$scale_finDataPlot=="Linear","","y"), xlab="Index", ylab=NA, col="green", col.axis="grey", col.lab="grey", col.main="grey", fg="black")
+ grid(col="grey")
+ }
+ }
+ })
+ })
+
+ ###Delete Button
+ observeEvent(input$finDataDelete, priority = 1,{
+ delData(input$database1_rows_selected)
+ })
+
+ ###DeleteAll Button
+ observeEvent(input$finDataDeleteAll, priority = 1,{
+ delData(input$database1_rows_all)
+ })
+
+ ###Save Button
+ output$finDataSave <- {
+ saveData()
+ }
+
+
+
+
+ ########################Load Your Data
+ ########################
+ ########################
+
+ ###Read file
+ fileUp_O <- reactive({
+ if (!is.null(input$yourFile$datapath)){
+ sep <- input$yourFileSep
+ if(input$yourFileSep=="default")
+ sep <- ""
+ if(input$yourFileHeader=="Only rows")
+ z <- read.table(input$yourFile$datapath ,sep = sep, header = FALSE, row.names = 1, check.names = FALSE)
+ if(input$yourFileHeader=="Only columns"){
+ z <- read.table(input$yourFile$datapath, sep = sep, header = FALSE, check.names = FALSE)
+ z <- data.frame(t(z), row.names = 1, check.names = FALSE)
+ z <- data.frame(t(z), check.names = FALSE)
+ }
+ if (input$yourFileHeader=="Both")
+ z <- read.table(input$yourFile$datapath, sep = sep, header = TRUE, check.names = FALSE)
+ if (input$yourFileHeader=="None")
+ z <- read.table(input$yourFile$datapath, sep = sep, header = FALSE, check.names = FALSE)
+ if (input$yourFileHeader=="Default")
+ z <- read.table(input$yourFile$datapath, sep = sep, check.names = FALSE)
+ if (input$yourFileHeader=="Only rows" | identical(colnames(z),paste("V",seq(1,length(colnames(z))),sep="")))
+ colnames(z) <- paste("X",seq(1,length(colnames(z))),"_",make.names(input$yourFile$name),sep="")
+ return(z)
+ }
+ })
+
+ ###Exchange rows/columns of file
+ fileUp_T <- reactive({
+ if (!is.null(input$yourFile$datapath)){
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/yuima -r 418
More information about the Yuima-commits
mailing list