[Yuima-commits] r423 - in pkg/yuimaGUI: . inst/yuimaGUI inst/yuimaGUI/www
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Fri Mar 25 01:28:32 CET 2016
Author: phoenix844
Date: 2016-03-25 01:28:32 +0100 (Fri, 25 Mar 2016)
New Revision: 423
Modified:
pkg/yuimaGUI/DESCRIPTION
pkg/yuimaGUI/inst/yuimaGUI/global.R
pkg/yuimaGUI/inst/yuimaGUI/server.R
pkg/yuimaGUI/inst/yuimaGUI/ui.R
pkg/yuimaGUI/inst/yuimaGUI/www/custom.css
Log:
Added first module (clustering) in Explorative Data Analysis
Modified: pkg/yuimaGUI/DESCRIPTION
===================================================================
--- pkg/yuimaGUI/DESCRIPTION 2016-03-21 15:25:26 UTC (rev 422)
+++ pkg/yuimaGUI/DESCRIPTION 2016-03-25 00:28:32 UTC (rev 423)
@@ -1,7 +1,7 @@
Package: yuimaGUI
Type: Package
Title: A Graphical User Interface for the Yuima Package
-Version: 0.4.3
+Version: 0.5.0
Author: YUIMA Project Team
Maintainer: Emanuele Guidotti <emanuele.guidotti at studenti.unimi.it>
Description: Provides a graphical user interface for the yuima package.
Modified: pkg/yuimaGUI/inst/yuimaGUI/global.R
===================================================================
--- pkg/yuimaGUI/inst/yuimaGUI/global.R 2016-03-21 15:25:26 UTC (rev 422)
+++ pkg/yuimaGUI/inst/yuimaGUI/global.R 2016-03-25 00:28:32 UTC (rev 423)
@@ -1,8 +1,11 @@
require(shiny)
require(DT)
+require(sde)
require(quantmod)
require(shinydashboard)
require(shinyBS)
+require(shinyRGL)
+require(rgl)
require(yuima)
require(shinyjs)
@@ -390,7 +393,7 @@
incProgress(1/tries, detail = paste(iter,"(/", tries ,")"))
for(j in 1:3){
for (i in miss)
- start[[i]] <- runif(1, min = max(lower[[i]],startMin[[i]]), max = min(upper[[i]],startMax[[i]]))
+ start[[i]] <- runif(1, min = max(lower[[i]],startMin[[i]], na.rm = TRUE), max = min(upper[[i]],startMax[[i]],na.rm = TRUE))
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")
@@ -406,7 +409,7 @@
threshold = threshold))
if (class(QMLEtemp)=="try-error")
break
- else if (summary(QMLEtemp)@m2logL>=0.999*m2logL)
+ else if (summary(QMLEtemp)@m2logL>=m2logL*abs(sign(m2logL)-0.001))
break
}
if(is.na(m2logL_prec) & class(QMLEtemp)!="try-error"){
@@ -427,7 +430,7 @@
}
}
}
- if (iter==tries & class(QMLEtemp)=="try-error"){
+ if (iter==tries & class(QMLEtemp)=="try-error" & !exists("QMLE")){
createAlert(session = session, anchorId = anchorId, content = paste("Unable to estimate", modName,"on", symbName), style = "danger")
return()
}
@@ -533,3 +536,52 @@
}
+
+MYdist <- function(object){
+ l <- length(colnames(object))
+ d <- matrix(ncol = l, nrow = l)
+ f <- function(x, dens){
+ res <- c()
+ for(xi in x){
+ if(xi %in% dens$x)
+ res <- c(res,dens$y[which(dens$x==xi)])
+ else{
+ if (xi > max(dens$x) | xi < min(dens$x))
+ res <- c(res,0)
+ else{
+ i_x1 <- which.min(abs(dens$x-xi))
+ i_x2 <- min(i_x1+1,length(dens$x))
+ res <- c(res, 0.5*(dens$y[i_x1]+dens$y[i_x2]))
+ }
+ }
+ }
+ return(res)
+ }
+ withProgress(message = 'Clustering: ', value = 0, {
+ k <- 1
+ for(i in 1:l)
+ for(j in i:l)
+ if (i!=j){
+ incProgress(2/(l*(l-1)), detail = paste(k,"(/", l*(l-1)/2 ,")"))
+ delta_i <- as.numeric(abs(mean(diff(index(object)[!is.na(object[,i])]))))
+ delta_j <- as.numeric(abs(mean(diff(index(object)[!is.na(object[,j])]))))
+ data_i <- Delt(na.omit(object[,i]))
+ data_i <- data_i[data_i!="Inf"]
+ data_j <- Delt(na.omit(object[,j]))
+ data_j <- data_j[data_j!="Inf"]
+ dens1 <- density(data_i/sqrt(delta_i)+mean(data_i, na.rm = TRUE)*(1-1/sqrt(delta_i)), na.rm = TRUE)
+ dens2 <- density(data_j/sqrt(delta_j)+mean(data_j, na.rm = TRUE)*(1-1/sqrt(delta_j)), na.rm = TRUE)
+ f_dist <- function(x) {abs(f(x,dens1)-f(x,dens2))}
+ npoints <- 1000
+ dist <- (max(tail(dens1$x,1), tail(dens2$x,1))-min(dens1$x[1],dens2$x[1]))/npoints*0.5*sum(f_dist(seq(from=min(dens1$x[1], dens2$x[1]), to=max(tail(dens1$x,1), tail(dens2$x,1)), length.out = npoints)))
+ d[j,i] <- ifelse(dist > 1, 1, dist)
+ k <- k + 1
+ }
+ })
+ rownames(d) <- colnames(object)
+ colnames(d) <- colnames(object)
+ return(as.dist(d))
+}
+
+
+
Modified: pkg/yuimaGUI/inst/yuimaGUI/server.R
===================================================================
--- pkg/yuimaGUI/inst/yuimaGUI/server.R 2016-03-21 15:25:26 UTC (rev 422)
+++ pkg/yuimaGUI/inst/yuimaGUI/server.R 2016-03-25 00:28:32 UTC (rev 423)
@@ -593,20 +593,20 @@
})
observeEvent(input$advancedSettingsButtonApplyModel,{
estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["fixed"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsFixed
- estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["start"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed),NA,input$advancedSettingsStart)
- estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["startMin"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed) | !is.na(input$advancedSettingsStart),NA,input$advancedSettingsStartMin)
- estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["startMax"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed) | !is.na(input$advancedSettingsStart),NA,input$advancedSettingsStartMax)
- estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["lower"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed),NA,input$advancedSettingsLower)
- estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["upper"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed),NA,input$advancedSettingsUpper)
+ estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["start"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsStart
+ estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["startMin"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsStartMin
+ estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["startMax"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsStartMax
+ estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["lower"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsLower
+ estimateSettings[[input$advancedSettingsModel]][[input$advancedSettingsSeries]][["upper"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsUpper
})
observeEvent(input$advancedSettingsButtonApplyAllModel,{
for (symb in input$database4_rows_all){
estimateSettings[[input$advancedSettingsModel]][[symb]][["fixed"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsFixed
- estimateSettings[[input$advancedSettingsModel]][[symb]][["start"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed),NA,input$advancedSettingsStart)
- estimateSettings[[input$advancedSettingsModel]][[symb]][["startMin"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed) | !is.na(input$advancedSettingsStart),NA,input$advancedSettingsStartMin)
- estimateSettings[[input$advancedSettingsModel]][[symb]][["startMax"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed) | !is.na(input$advancedSettingsStart),NA,input$advancedSettingsStartMax)
- estimateSettings[[input$advancedSettingsModel]][[symb]][["lower"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed),NA,input$advancedSettingsLower)
- estimateSettings[[input$advancedSettingsModel]][[symb]][["upper"]][[input$advancedSettingsParameter]] <<- ifelse(!is.na(input$advancedSettingsFixed),NA,input$advancedSettingsUpper)
+ estimateSettings[[input$advancedSettingsModel]][[symb]][["start"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsStart
+ estimateSettings[[input$advancedSettingsModel]][[symb]][["startMin"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsStartMin
+ estimateSettings[[input$advancedSettingsModel]][[symb]][["startMax"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsStartMax
+ estimateSettings[[input$advancedSettingsModel]][[symb]][["lower"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsLower
+ estimateSettings[[input$advancedSettingsModel]][[symb]][["upper"]][[input$advancedSettingsParameter]] <<- input$advancedSettingsUpper
}
})
observeEvent(input$advancedSettingsButtonApplyGeneral,{
@@ -1471,8 +1471,134 @@
)
}
+
+
+
+
+
+
+
+
+
+
+ ########################Clustering
+ ########################
+ ########################
+
+ ###Display available data
+ output$cluster_table_select <- DT::renderDataTable(options=list(scrollY = 150, scrollCollapse = FALSE, deferRender = TRUE, dom = 'frtS'), 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)
+ })
+
+ ###Table of selected data to cluster
+ seriesToCluster <- reactiveValues(table=data.frame())
+
+ ###Select Button
+ observeEvent(input$cluster_button_select, priority = 1, {
+ seriesToCluster$table <<- rbind(seriesToCluster$table, yuimaGUItable$series[(rownames(yuimaGUItable$series) %in% input$cluster_table_select_rows_selected) & !(rownames(yuimaGUItable$series) %in% rownames(seriesToCluster$table)),])
+ })
+
+ ###SelectAll Button
+ observeEvent(input$cluster_button_selectAll, priority = 1, {
+ seriesToCluster$table <<- rbind(seriesToCluster$table, yuimaGUItable$series[(rownames(yuimaGUItable$series) %in% input$cluster_table_select_rows_all) & !(rownames(yuimaGUItable$series) %in% rownames(seriesToCluster$table)),])
+ })
+
+ ###Display Selected Data
+ output$cluster_table_selected <- DT::renderDataTable(options=list(order = list(1, 'desc'), scrollY = 150, scrollCollapse = FALSE, deferRender = TRUE, dom = 'frtS'), extensions = 'Scroller', rownames = FALSE, selection = "multiple",{
+ if (length(seriesToCluster$table)==0){
+ NoData <- data.frame("Symb"=NA,"From"=NA, "To"=NA)
+ return(NoData[-1,])
+ }
+ return (seriesToCluster$table)
+ })
+
+ ###Control selected data to be in yuimaGUIdata$series
+ observe({
+ if(length(seriesToCluster$table)!=0){
+ if (length(yuimaGUItable$series)==0)
+ seriesToCluster$table <<- data.frame()
+ else
+ seriesToCluster$table <<- seriesToCluster$table[which(as.character(seriesToCluster$table[,"Symb"]) %in% as.character(yuimaGUItable$series[,"Symb"])),]
+ }
+ })
+
+ ###Delete Button
+ observeEvent(input$cluster_button_delete, priority = 1,{
+ if (!is.null(input$cluster_table_selected_rows_selected))
+ seriesToCluster$table <<- seriesToCluster$table[-which(rownames(seriesToCluster$table) %in% input$cluster_table_selected_rows_selected),]
+ })
+
+ ###DeleteAll Button
+ observeEvent(input$cluster_button_deleteAll, priority = 1,{
+ seriesToCluster$table <<- seriesToCluster$table[-which(rownames(seriesToCluster$table) %in% input$cluster_table_selected_rows_all),]
+ })
+
+ observeEvent(input$cluster_button_startCluster, {
+ closeAlert(session, "cluster_alert_dist")
+ if (length(rownames(seriesToCluster$table))!=0){
+ names_list <- rownames(seriesToCluster$table)
+ x <- yuimaGUIdata$series[[names_list[1]]]
+ for(i in names_list[-1])
+ x <- merge(x, yuimaGUIdata$series[[i]])
+ colnames(x) <- names_list
+ d <- switch(
+ input$cluster_distance,
+ "MOdist" = try(MOdist(na.omit(x))),
+ "MYdist" = try(MYdist(x))
+ )
+ if (class(d)=="try-error")
+ createAlert(session, anchorId = "cluster_alert", alertId = "cluster_alert_dist", content = "Error in clustering", style = "error")
+ else{
+ hc <- hclust(d)
+ labelColors <- c("#CDB380", "#036564", "#EB6841", "#EDC951")
+ dendrClick <- reactiveValues(y = NULL)
+ output$cluster_dendogram <- renderPlot({
+ if(!is.null(input$cluster_dendrogram_click$y))
+ dendrClick$y <- input$cluster_dendrogram_click$y
+ if(!is.null(dendrClick$y)){
+ clusMember = cutree(hc, h = dendrClick$y)
+ colLab <- function(n) {
+ if (is.leaf(n)) {
+ a <- attributes(n)
+ labCol <- labelColors[clusMember[which(names(clusMember) == a$label)]]
+ attr(n, "nodePar") <- c(a$nodePar, lab.col = labCol)
+ }
+ n
+ }
+ hc <- dendrapply(as.dendrogram(hc), colLab)
+ }
+ if(is.null(dendrClick$y)){
+ colDefault <- function(n){
+ if (is.leaf(n))
+ attr(n, "nodePar") <- c(attributes(n)$nodePar, lab.col = labelColors[1])
+ return(n)
+ }
+ hc <- dendrapply(as.dendrogram(hc), colDefault)
+ }
+ par(bg="#471a1a", xaxt = "n", mar= c(10, 4, 4, 2)+0.1)
+ plot(hc, ylab = "", xlab = "", main = "Dendrogram", edgePar=list(col="grey50"), col.main = "#FFF68F")
+ })
+ output$cluster_scaling2D <- renderPlot({
+ points <- cmdscale(d)
+ if(!is.null(dendrClick$y))
+ g1 <- cutree(hclust(d), h = dendrClick$y)
+ else
+ g1 <- 1
+ par(bg="#471a1a", xaxt = "n", yaxt = "n", bty="n")
+ plot(points, col=labelColors[g1], pch=16, cex=2, main = "Multidimensional scaling", col.main = "#FFF68F", xlab="", ylab="")
+ })
+ }
+ }
+ })
+
+
+
+
-
}
Modified: pkg/yuimaGUI/inst/yuimaGUI/ui.R
===================================================================
--- pkg/yuimaGUI/inst/yuimaGUI/ui.R 2016-03-21 15:25:26 UTC (rev 422)
+++ pkg/yuimaGUI/inst/yuimaGUI/ui.R 2016-03-25 00:28:32 UTC (rev 423)
@@ -9,7 +9,9 @@
menuSubItem("Financial & Economic Data", tabName = "finData"),
menuSubItem("Your Data", tabName = "yourData")
),
- menuItem("Explorative Data Analysis", tabName = "eda", icon = icon("map")),
+ menuItem("Explorative Data Analysis", tabName = "eda", icon = icon("map"),
+ menuSubItem("Clustering", tabName = "cluster")
+ ),
menuItem("Modelling & Model Selection", tabName = "models", icon = icon("sliders")),
menuItem("Simulate", tabName = "simulate", icon = icon("area-chart")),
hr(),
@@ -472,6 +474,44 @@
column(6,tags$button(type="button", id="simulate_button_applyAll_advancedSettings", class = "action-button", em("Apply All")))
)
)
+ ),
+ ####################################################
+ tabItem(tabName = "cluster",
+ fluidRow(column(12,bsAlert("cluster_alert"))),
+ fluidRow(column(12,
+ column(4,
+ h4("Available data", style="color:#CDCECD"),
+ DT::dataTableOutput("cluster_table_select"),
+ br(),
+ fluidRow(
+ column(6,actionButton("cluster_button_select",label = "Select", align = "center")),
+ bsTooltip("cluster_button_select", title = "Select data to cluster", placement = "top"),
+ column(6,actionButton("cluster_button_selectAll",label = "Select All", align = "center")),
+ bsTooltip("cluster_button_selectAll", title = "Select all data that are displayed", placement = "top")
+ )
+ ),
+ column(4,
+ h4("Selected data", style="color:#CDCECD"),
+ DT::dataTableOutput("cluster_table_selected"),
+ br(),
+ fluidRow(
+ column(6,actionButton("cluster_button_delete",label = "Delete", align = "center")),
+ bsTooltip("cluster_button_delete", title = "Delete selected data", placement = "top"),
+ column(6,actionButton("cluster_button_deleteAll",label = "Delete All", align = "center")),
+ bsTooltip("cluster_button_deleteAll", title = "Delete all data that are displayed", placement = "top")
+ )
+ ),
+ column(4,br(),br(),br(),br(),
+ div(align="center",selectInput("cluster_distance", "Distance", choices = c("Markov Operator"="MOdist", "My distance"="MYdist"))),
+ br(),br(),br(),br(),br(),br(),
+ actionButton("cluster_button_startCluster", label = "Start Clustering", align = "center")
+ )
+ )),
+ br(),
+ fluidRow(
+ column(8, plotOutput("cluster_dendogram", click = "cluster_dendrogram_click")),
+ column(4, plotOutput("cluster_scaling2D"))
+ )
)
########################new tab items below
)
Modified: pkg/yuimaGUI/inst/yuimaGUI/www/custom.css
===================================================================
--- pkg/yuimaGUI/inst/yuimaGUI/www/custom.css 2016-03-21 15:25:26 UTC (rev 422)
+++ pkg/yuimaGUI/inst/yuimaGUI/www/custom.css 2016-03-25 00:28:32 UTC (rev 423)
@@ -53,7 +53,7 @@
background: linear-gradient(#606D60, #202220, #606D60);
}
-#finDataDelete, #finDataDeleteAll, #finDataSave, #yourFileDelete, #yourFileDeleteAll, #yourFileSave, #buttonSelect_models_Univariate, #buttonSelectAll_models_Univariate, #buttonDelete_models_Univariate, #buttonDeleteAll_models_Univariate, #databaseModelsDelete, #databaseModelsDeleteAll, #simulation_button_deleteModels, #simulation_button_deleteAllModels, #simulate_button_selectModels, #simulate_button_selectAllModels, #simulate_monitor_button_delete, #simulate_monitor_button_deleteAll, #simulate_monitor_button_showSimulation, #simulate_model_usr_button_select, #simulate_model_usr_button_selectAll, #simulate_model_usr_button_delete, #simulate_model_usr_button_deleteAll{
+#finDataDelete, #finDataDeleteAll, #finDataSave, #yourFileDelete, #yourFileDeleteAll, #yourFileSave, #buttonSelect_models_Univariate, #buttonSelectAll_models_Univariate, #buttonDelete_models_Univariate, #buttonDeleteAll_models_Univariate, #databaseModelsDelete, #databaseModelsDeleteAll, #simulation_button_deleteModels, #simulation_button_deleteAllModels, #simulate_button_selectModels, #simulate_button_selectAllModels, #simulate_monitor_button_delete, #simulate_monitor_button_deleteAll, #simulate_monitor_button_showSimulation, #simulate_model_usr_button_select, #simulate_model_usr_button_selectAll, #simulate_model_usr_button_delete, #simulate_model_usr_button_deleteAll, #cluster_button_select, #cluster_button_selectAll, #cluster_button_delete, #cluster_button_deleteAll{
font-size: 110%;
width: 100%;
color: black;
@@ -86,7 +86,7 @@
background: radial-gradient(#a5bdc9, #184860, #061218);
}
-#hideEstimatedModels, #showEstimatedModels, #EstimateModels, #simulate_simulateModels, #simulate_button_showMonitor, #simulate_button_hideMonitor {
+#EstimateModels, #simulate_simulateModels, #cluster_button_startCluster {
width: 100%;
color: #ffffff;
text-shadow: 1px 1px 1px #000;
More information about the Yuima-commits
mailing list