[Robast-commits] r864 - branches/robast-1.0/pkg/RobExtremesBuffer
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Mon Nov 9 13:52:06 CET 2015
Author: eugenm123
Date: 2015-11-09 13:52:05 +0100 (Mon, 09 Nov 2015)
New Revision: 864
Removed:
branches/robast-1.0/pkg/RobExtremesBuffer/.RData
branches/robast-1.0/pkg/RobExtremesBuffer/.Rhistory
Modified:
branches/robast-1.0/pkg/RobExtremesBuffer/config.R
branches/robast-1.0/pkg/RobExtremesBuffer/server.R
branches/robast-1.0/pkg/RobExtremesBuffer/ui.R
branches/robast-1.0/pkg/RobExtremesBuffer/utilities.R
Log:
Speichern und Laden des Verlaufs (History).
Deleted: branches/robast-1.0/pkg/RobExtremesBuffer/.RData
===================================================================
(Binary files differ)
Deleted: branches/robast-1.0/pkg/RobExtremesBuffer/.Rhistory
===================================================================
--- branches/robast-1.0/pkg/RobExtremesBuffer/.Rhistory 2015-11-09 10:10:50 UTC (rev 863)
+++ branches/robast-1.0/pkg/RobExtremesBuffer/.Rhistory 2015-11-09 12:52:05 UTC (rev 864)
@@ -1,447 +0,0 @@
-dir("/Bibliotheken/Oldenburg/VeranstSS2015/ZRA")
-dir("Bibliotheken:/Oldenburg/VeranstSS2015/ZRA")
-dir("Bibliotheken/Oldenburg/VeranstSS2015/ZRA")
-require(RODBC)
-q()
-require(Rcmdr)
-setwd("C:/rtest/RobASt/branches/robast-1.0/pkg/RobExtremesBuffer")
-if(!require(shiny)) install.packages("shiny", dep=TRUE)
-#library(shiny)
-options(shiny.error=NULL)
-options(shiny.trace=F)
-source("utilities.R")
-source("config.R")
-NAMES_LM <- c("b","a.a[sc]","a.a[sh]","z.i[sc]","z.i[sh]",
-"A.a[sc,sc]","A.a[sc,sh]","A.a[sh,sc]","A.a[sh,sh]",
-"A.i[sc,sc]","A.i[sc,sh]","A.i[sh,sc]","A.i[sh,sh]")
-HISTORY_COMMITS_FILE = "history.rda"
-dataEnviron <- load.file.to("sysdata.rda")
-main.title <- function(gridName, familyName){
-familyName1 <- gsub(" [F,f]amily","", familyName)
-return(paste(gridName, familyName1, sep="-"))
-}
-get.num.multiplicators <- function(gridName, family){
-if(gridName=="Sn")
-return(1)
-return(if(family == "GEVU Family") 25 else 13)
-}
-## Uses the list of all ranges and deletes the required one
-##
-## For deletion is the string value of input$ranges used,
-## i.e. one assumes the index of the entry is in the string which.to.delete.
-## The format of the string should be "Index : somevalues"
-##
-## If the index is invalid or null the full range is returned
-update.ranges.after.delete <- function(allRanges, which.to.delete){
-result <- allRanges
-if (!is.null(which.to.delete)){
-idx.to.delete <- as.numeric(gsub(" : .*$", "", which.to.delete))
-if (!is.na(idx.to.delete)){
-result[[idx.to.delete]] <- NULL
-}
-}
-return(result)
-}
-# print.ranges <- function(ranges){
-# print(paste(sapply(1:length(ranges), function(i)paste(i, length(ranges)))))
-# }
-## Create the list of range as strings for the list output
-update.ranges.output <- function(ranges){
-if(is.null(ranges))
-return(NULL)
-rangeNums <- sapply(ranges, function(x)paste(round(x, digits=3), collapse=", "))
-result <- sapply(seq_along(rangeNums), function(i)paste(i, ':', rangeNums[[i]]))
-return(result)
-}
-## Create smooth grid
-calc.smooth.grid <- function(grid, df, grid.restrictions){
-# grid[,1] - The grid positions
-# grid[,2:end] - the Lagrange multiplier values
-result <- .MakeSmoothGridList(grid[,1], grid[,-1], df=df, gridRestrForSmooth=grid.restrictions)
-return(result)
-}
-zoom.history <<- NULL
-zoom.in <- function(brush, zoom.list){
-# Unfortunately this method is called twice (probably for each coordinate)
-# Hence we need to do the if check for not adding an element twice
-# It uses the heuristics that two distinguishing boxes will differ in both, xlim and ylim values
-if (is.null(brush))
-return(NULL)
-# store to history if the last differs from current
-if (can.push(zoom.history, zoom.list)){
-last.idx <- length(zoom.history)
-zoom.history[[last.idx + 1]] <<- zoom.list
-# set new values
-res <- list (xlim=c(brush$xmin, brush$xmax), ylim=c(brush$ymin, brush$ymax))
-return(res)
-}
-return(NULL)
-}
-zoom.out <- function(){
-idx.last <- length(zoom.history)
-if(idx.last > 0){
-last <- zoom.history[[idx.last]]
-zoom.history <<- zoom.history[1:(idx.last-1)]
-res <-list(xlim=c(last$xlim[1], last$xlim[2]), ylim=c(last$ylim[1], last$ylim[2]))
-return(res)
-}
-return(NULL)
-}
-prev.deleted <<- ""
-delete.ranges <- function(whichLM, state.ranges, input.ranges){
-if(!is.null(input.ranges) && (prev.deleted != input.ranges)){
-res <- update.ranges.after.delete(allRanges=state.ranges[[whichLM]], which.to.delete=input.ranges)
-prev.deleted <<- input.ranges
-return(res)
-}else{
-prev.deleted <<- ""
-return(NULL)
-}
-}
-get.restrictions.for.smooth <- function(which, from, grid.param){
-if (length(from)==0)
-return(NULL)
-ranges <- from[[which]]
-if (!is.null(ranges) && length(ranges) > 0){
-return(ranges.to.grid(ranges, grid.param))
-}
-return(NULL)
-}
-# We have grid as global, since we want to do testing.
-smoothed.totalgrid <<- NULL
-gen.grid.for.save <- function(familyName, gridName, selected.grid, dfs, ranges){
-num.LMs <- get.num.multiplicators(gridName, familyName)
-grid.params <- selected.grid[,1]
-total.grid <- sapply(1:num.LMs, function(i){
-restrictions <- get.restrictions.for.smooth(i, ranges, grid.params)
-smoothed <- calc.smooth.grid(selected.grid, dfs[[i]], restrictions)
-return(smoothed[,i+1])
-})
-total.grid <- cbind(grid.params, total.grid)
-if(TEST.save.grid)
-smoothed.totalgrid <<- total.grid
-return(total.grid)
-}
-###########################################################################
-# history local grid save intermediate will be saved in history Rdata
-# (analogue as in sysdata.rda, see Sec. 5 WriteUp-Interpolators.txt)
-# [OptCrit],
-# > [model1],
-# >> [timestamp]
-# >>> [ranges]
-# >>> [dfs]
-###########################################################################
-local.commit.grid <- function(familyName, gridName, dfs, ranges){
-commits.env <- load.file.to(HISTORY_COMMITS_FILE, on.not.exist=function(x)new.env())
-# Get entry
-grid.lookup <- get.grid.lookup(gridName)
-family.lookup <- get.family.lookup(familyName)
-if(exists(grid.lookup, envir=commits.env)){
-models <- get(grid.lookup, envir=commits.env)
-}else{
-models <- list()
-}
-# append
-if(is.null(models[[family.lookup]])){
-models[[family.lookup]] <- list()
-}
-timestamp = format(Sys.time())
-models[[family.lookup]][[timestamp]] <- list(dfs=dfs, ranges=ranges)
-assign(grid.lookup, value=models, envir=commits.env)
-names <- ls(commits.env, all.names=TRUE)
-save(list=names, file=HISTORY_COMMITS_FILE, envir=commits.env)
-}
-save.grid.to.csv <- function(familyName, gridName, selected.grid, dfs, ranges){
-require(ROptEst)
-total.grid <- gen.grid.for.save(familyName, gridName, selected.grid, dfs, ranges)
-dest.file.name <- paste0("interpol", familyName, gridName, ".csv")
-.saveGridToCSV(total.grid, dest.file.name, gridName, paste0(".", familyName))
-}
-shinyServer(function(input, output, session){
-######################################################################################
-## Set parameters
-output$resetNote <- renderText("<strong>Durch Ändern der Grid & Familie, gehen alle nicht-gespeicherte Intervalle verloren.</strong>")
-## prepare data
-grids <- reactive({ # Depends on input${gridName, familyName}
-load.grids.env(dataEnviron, gridName=input$gridName, familyName=input$familyName)
-})
-######################################################################################
-## Construct plot parameters
-observe({ # Depends on input${familyName}. Sets input$whichLM
-updateSliderInput(session, inputId="whichLM", max=get.num.multiplicators(input$gridName, input$familyName))
-}, label="set number of multiplicatorsd value")
-observe({ # Depends on input${gridName, whichLM}. Set input$whichLM
-if ((input$gridName == "Sn") && input$whichLM != 1){
-updateSliderInput(session, inputId="whichLM", value=1)
-}
-}, label="whichLM value for SnGrid")
-observe({ # Depends on input$df. Outputs output$df, restrictionState$df
-if(input$df > 0){
-whichLM <- isolate(input$whichLM)
-restrictionState$df[[whichLM]] <- input$df
-}else{
-updateNumericInput(session, "df", value=1)
-}
-}, label="update df")
-grid.orig <- reactive({grids()[["orig"]]}) # Depends on grids()
-grid.smoothed <- reactive({grids()[["smoothed"]]}) # Depends on grids()
-# grid.selected <- reactive({ if(input$withSmooth) grid.smoothed() else grid.orig() }) # Depends on input$withSmooth, grid.smoothed(), grid.orig()
-grid.selected <- reactive({grid.orig()})
-getDf <- reactive({ # Depends on restrictionState$df, input$whichLM
-return(restrictionState$df[[input$whichLM]])
-}, label="Returns the degree of freedom for selected LM")
-gridRestrictionForSmooth <- reactive({ # Depends on restrictionState$ranges, grid.selected(), input$whichLM
-res <- get.restrictions.for.smooth(input$whichLM, restrictionState$ranges, grid.selected()[,1])
-return(res)
-}, label="Returns smoothing grid restrictions.")
-grid <- reactive({ # Depends on grid.selected(), gridRestrictionForSmooth(), getDf()
-grid=grid.selected()
-result <- calc.smooth.grid(grid=grid, df=getDf(), grid.restrictions=gridRestrictionForSmooth())
-return(result)
-}, label="Select current grid")
-plotGridRestriction <- reactive({return(list(rep(TRUE, nrow(grid()))))}) # Depends on grid()
-######################################################################################
-## smooth restrictions
-# Represents three states:
-# (1) no current restriction (i.e. currently: both NULL; first will get some value)
-# (2) restriction started (i.e. currently: first HAS some value; second will get)
-# (3) restriction finished (i.e currently: both HAS some value, will remove all)
-#
-# Removing will be done by clicking on existing first. (i.e. currently: first HAS some value; it will be removed)
-# Then we will get to state (1)
-# The sw
-#
-#
-# So the automata look like: (-1) -> (1) <-> (2)
-# \--<<--/
-restrictions.init <<- NULL # We do not want them as responsive events.
-restrictionState <- reactiveValues(state=NULL, ranges=NULL, df=NULL)
-reset.restrictions <- function(){
-num.multiplicators <- get.num.multiplicators(isolate(input$gridName), isolate(input$familyName))
-restrictions.init <<- NULL
-restrictionState$ranges <- create.list.of.empty.lists(num.multiplicators)
-restrictionState$df <- as.list(rep(10, num.multiplicators))
-}
-get.restrictions.state <- reactive({ # depends on input$plot_dblclick
-click <- input$plot_dblclick
-result <- list(click=isolate(click), state=-1)
-if(!is.null(click)){
-result$state <- if(is.null(restrictions.init)) 1 else 2
-}
-return(result)
-}, label="get restrictions state")
-observe({ # depends on get.restrictions.state(), restrictionState${ranges, state}, input$whichLM
-whichLM <- isolate(input$whichLM)
-state <- get.restrictions.state()
-click <- state$click
-if(state$state == 1){ # (1)=>(2)
-restrictions.init <<- list(x=click$x, y=click$y)
-restrictionState$state <- 2
-}else if((state$state == 2) && (!is.null(restrictions.init$x))){ # (2)=> (1)
-# If we click close to the first point, the first point is removed and we are in the state 1 again...
-close.to.frist.Pts <- nearPoints(as.data.frame(restrictions.init), click, xvar="x", yvar="y")
-if(dim(close.to.frist.Pts)[1] == 0){ # Otherwise: we add the the point to our ranges
-ranges <- isolate(restrictionState$ranges[[whichLM]])
-ranges <- updateRanges(ranges, c(restrictions.init$x, click$x))
-restrictionState$ranges[[whichLM]] <- ranges
-}
-restrictionState$state <- 1
-restrictions.init <<- NULL
-}
-}, label="restrictions state changer")
-observe({ # depends on: restrictionState$ranges. Sets: output$ranges, input$whichLM
-df <- getDf()
-if(df != isolate(input$df)){
-updateNumericInput(session, "df", value=df)
-}
-updateSelectInput(session, "ranges", choices=update.ranges.output(restrictionState$ranges[[input$whichLM]]))
-}, label="update ranges and df on whichLM-Change")
-prev.deleted <<- "" # Somehow the deleteRange is multiple times not null. So we need to store a value to distinguish them.
-observe({ # depends on input${deleteRange. ranges, whichLM}. Sets restrictionState$ranges
-if(!is.null(input$deleteRange)){
-whichLM <- isolate(input$whichLM)
-res <- delete.ranges(whichLM, isolate(restrictionState$ranges), isolate(input$ranges))
-if (!is.null(res))
-restrictionState$ranges[[whichLM]] <- res
-}
-}, label="delete ranges")
-observe({
-if(input$addToHistory){
-local.commit.grid(isolate(input$familyName),
-isolate(input$gridName),
-isolate(restrictionState$df),
-isolate(restrictionState$ranges))
-}
-}, label="save local grid")
-######################################################################################
-# zoom
-zoom <- reactiveValues(xlim=NULL, ylim=NULL)
-reset.zoom <- function(){
-zoom.history <<- list() # HACK: only global variables can be used to pass states between reactives
-zoom$xlim <- NULL
-zoom$ylim <- NULL
-}
-observe({ # depends on input${plot_brush}, zoom,
-res <- zoom.in(input$plot_brush, isolate(reactiveValuesToList(zoom)))
-if(!is.null(res)){
-zoom$xlim <- res$xlim
-zoom$ylim <- res$ylim
-}
-}, label="Zoom in")
-# zoom out
-observe({ # depends on input${zoomOut}, modifies zoom
-if (input$zoomOut){
-res <- zoom.out()
-if(!is.null(res)){
-zoom$xlim <- res$xlim
-zoom$ylim <- res$ylim
-# The event for replotting should be fired now
-}
-}
-}, label="Zoom Out")
-######################################################################################
-## Reset function
-observe({ # depends on zoom, input${whichLM, familyName, gridName}
-reset <- function(){reset.zoom(); reset.restrictions() }
-if(!is.null(input$familyName)) reset()
-if(!is.null(input$gridName)) reset()
-}, label="reset")
-######################################################################################
-## Save to grid
-observe({ # Depends: input${saveGrid, familyName, gridName}, restrictionState$df, grid.selected()
-if(input$saveGrid){
-save.grid.to.csv(familyName=isolate(input$familyName),
-gridName=isolate(input$gridName),
-selected.grid=isolate(grid.selected()),
-dfs=isolate(restrictionState$df),
-ranges=isolate(restrictionState$ranges))
-####################################################
-# TEST of save.grid.to.csv
-####################################################
-if(TEST.save.grid){
-whichLM <- input$whichLM
-grid <- isolate(grid())
-if(!is.null(smoothed.totalgrid) && whichLM >= 1 && whichLM <= (ncol(smoothed.totalgrid)+1)){
-# Test dims
-if (!all(dim(grid), dim(smoothed.totalgrid))){
-print("not equal sizes: dim(grid)=", paste(dim(grid), collapse=","),
-"dim(st.grid)=", paste(dim(smoothed.totalgrid), collapse=","))
-}else{
-# print("dims OK")
-}
-# Test first column
-diff.param <- abs(grid[,1] - smoothed.totalgrid[,1])
-if (! all(diff.param <= 10^-7)){
-print("invalid params:")
-print(paste("grid", paste(head(grid[,1]), collapse=",")))
-print(paste("st.grid", paste(head(smoothed.totalgrid[,1]), collapse=",")))
-}else{
-# print("params OK")
-}
-# test cur lm column
-whichLM <- isolate(input$whichLM)+1
-diff.lm.grid <- abs(grid[,whichLM] - smoothed.totalgrid[,whichLM])
-if (! all(diff.lm.grid <= 10^-7)){
-print(paste("invalid lm grid:", whichLM))
-print(paste("grid", paste(head(grid[,whichLM]), collapse=",")))
-print(paste("st.grid", paste(head(smoothed.totalgrid[,whichLM]), collapse=",")))
-}else{
-# print(paste("grid", whichLM, "OK"))
-}
-}
-}
-####################################################
-}
-}, label="save grids to csv")
-######################################################################################
-## plot
-output$out <- renderPlot({
-args <- list(grid = grid(),
-grid.orig = grid.orig(),
-grid.smoothed = grid.smoothed(),
-idxCol = input$whichLM + 1, # +1 because 1. col are the points of xi
-xlab = expression(xi),
-lty = c(2, 3, 1),
-lwd = c(0.8, 0.8, 1.8),
-col = 1:3,
-main = main.title(input$gridName, input$familyName),
-ylab = paste("LM", NAMES_LM[input$whichLM]),
-restriction = plotGridRestriction()[[1]],
-withLegend = input$withLegend)
-# Zoom
-args[["xlim"]] <- zoom$xlim
-args[["ylim"]] <- zoom$ylim
-## plot
-do.call(matlines.internal, args)
-## smooth restricton selector
-# (1) => plot first.
-# (2) => plot first.
-# (3) => nothing.
-if(!is.null(restrictionState$state)){
-state <- isolate(restrictionState$state)
-if(state == 2){
-click <- restrictions.init
-points(click$x, click$y, pch=4, col="red", lwd=3)
-}
-}
-})
-})
-shinyUI(fluidPage(
-titlePanel("Smoother"),
-fluidRow(
-column(1,
-radioButtons("gridName",
-label = "Grid auswählen",
-choices = c("Sn", "OMSE", "RMXE", "MBRE")
-),
-radioButtons("familyName",
-label = "Familie auswählen",
-choices = c("Generalized Pareto Family",
-"GEV Family",
-"GEVU Family",
-"Gamma family",
-"Weibull Family")
-),
-htmlOutput("resetNote")
-), # column
-column(3,
-# checkboxInput("withSmooth", label="Plot with Smooth"),
-sliderInput("whichLM", label="L-Multiplikator auswählen", min=1, max=10, value=1),
-numericInput("df", "DF", 10),
-selectInput("ranges", label="Glättung-Ausschluss-Intervalle", choices=NULL, size=10, selectize=FALSE),
-actionButton("deleteRange", label="Interval löschen"),
-fluidRow(
-column(6, actionButton("saveGrid", label="Speichere Grid (CSV)")),
-column(6, actionButton("addToHistory", label="Zu History hinzufügen"))
-)
-), # column
-column(8,
-plotOutput("out", brush=brushOpts("plot_brush", delay=300, resetOnNew=TRUE), # brush for zoom
-dblclick="plot_dblclick", # double click to select ranges
-height="600px"
-),
-fluidRow(
-column(1, actionButton("zoomOut", label="Zoom Out", icon=icon("zoom-out", lib="glyphicon"))),
-column(2, offset=1, checkboxInput("withLegend", label="Legende anzeigen", value=TRUE))
-)
-) # column
-) # fluidRow
-))
-shiny::runApp()
-shiny::runApp()
-?plotOutput
-help(package="shiny")
-q()
-install.packages("shiny")
-shiny::runApp()
-shiny::runApp()
-shiny::runApp()
-??get0
-shiny::runApp()
-shiny::runApp()
-install.packages("shinyjs")
-shiny::runApp()
-shiny::runApp()
-shiny::runApp()
-shiny::runApp()
-shiny::runApp()
Modified: branches/robast-1.0/pkg/RobExtremesBuffer/config.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremesBuffer/config.R 2015-11-09 10:10:50 UTC (rev 863)
+++ branches/robast-1.0/pkg/RobExtremesBuffer/config.R 2015-11-09 12:52:05 UTC (rev 864)
@@ -17,4 +17,6 @@
TEST.save.grid <- TRUE
-REQUIRED_PACKAGES <- c("shiny", "shinyjs", "ROptEst")
\ No newline at end of file
+REQUIRED_PACKAGES <- c("shiny", "shinyjs", "ROptEst")
+
+HISTORY_COMMITS_FILE <- "history.rda"
Modified: branches/robast-1.0/pkg/RobExtremesBuffer/server.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremesBuffer/server.R 2015-11-09 10:10:50 UTC (rev 863)
+++ branches/robast-1.0/pkg/RobExtremesBuffer/server.R 2015-11-09 12:52:05 UTC (rev 864)
@@ -10,7 +10,7 @@
RESET_NOTE_TEXT <- "<strong>Durch aendern der Grid & Familie, gehen alle nicht-gespeicherte Intervalle verloren.</strong>"
DEFAULT_DEGREE_OF_FREEDOM <- 10
-loadedData <- load.file.to("sysdata.rda")
+loadedData <- loadRDataFileToEnv("sysdata.rda")
zoomHistory <<- NULL
prev.deleted <<- ""
# We have grid as global, since we want to do testing.
@@ -49,7 +49,9 @@
observe({ # Depends on getCurrentGridName(), getCurrentFamilyName(). Sets input$whichLM
maxNumMultiplicators <- getNumMultiplicators(getCurrentGridName(), getCurrentFamilyName())
updateSliderInput(session, inputId="whichLM", max=maxNumMultiplicators)
- }, label="set number of multiplicatorsd value")
+ isLoadFromHistoryEnabled <- hasHistory(getCurrentFamilyName(), getCurrentGridName())
+ toogleAvailabilityComponents("loadFromHistory", isLoadFromHistoryEnabled)
+ }, label="form components setting on grid & family")
getOriginalGrid <- reactive({
res <- loadGrids()[["orig"]]
@@ -119,6 +121,7 @@
configuration$useExisting <- as.list(rep(FALSE, numMultiplicators))
}
+
observe({ # Depends on getInputDf(). Outputs output$df, configuration$df
if(getInputDf() > 0) {
whichLM <- isolate(getCurrentLM())
@@ -128,19 +131,17 @@
}
}, label="update df")
+
observe({ # input$takeUsed, getCurrentLM()
COMPONENTS <- c('df', 'ranges', 'deleteRange')
whichLM <- isolate(getCurrentLM())
configuration$useExisting[[whichLM]] <- input$takeUsed
- if(input$takeUsed){
- sapply(COMPONENTS, function(x)shinyjs::disable(x))
- } else {
- sapply(COMPONENTS, function(x)shinyjs::enable(x))
- }
+ toogleAvailabilityComponents(COMPONENTS, !input$takeUsed)
}, label="Use saved grid checkbox")
+
observe({ # depends on: configuration$ranges. Sets: output$ranges, getCurrentLM()
lm <- getCurrentLM()
df <- getCurrentDf()
@@ -159,6 +160,7 @@
updateSelectInput(session, "ranges", choices=update.ranges.output(ranges))
}, label="Set configuration for current LM")
+
getCurrentStateForRestrictions <- reactive({ # depends on input$plot_dblclick
click <- input$plot_dblclick
result <- list(click=isolate(click), state=-1)
@@ -205,10 +207,21 @@
observe({
if(input$addToHistory){
- local.commit.grid(isolate(getCurrentFamilyName()), isolate(getCurrentGridName()),
- isolate(configuration$df), isolate(configuration$ranges))
+ addToHistory(isolate(getCurrentFamilyName()), isolate(getCurrentGridName()),
+ isolate(configuration$df), isolate(configuration$ranges),
+ isolate(configuration$useExisting))
}
}, label="save local grid")
+
+ observe({
+ if(input$loadFromHistory){
+ ##1
+ values <- loadFromHistory(getCurrentFamilyName(), getCurrentGridName())
+ configuration$df <- values$df
+ configuration$ranges <- values$ranges
+ configuration$useExisting <- values$useExisting
+ }
+ }, label="load from grid")
######################################################################################
# zoom
zoom <- reactiveValues(xlim=NULL, ylim=NULL)
@@ -223,21 +236,37 @@
if(!is.null(res)){
zoom$xlim <- res$xlim
zoom$ylim <- res$ylim
+
+ updateNumericInput(session, "zoomYlimMin", value=res$ylim[1])
+ updateNumericInput(session, "zoomYlimMax", value=res$ylim[2])
}
}, label="Zoom in")
# zoom out
observe({ # depends on input${zoomOut}, modifies zoom
if (input$zoomOut){
- res <- zoom.out()
+ res <- zoomOut()
if(!is.null(res)){
zoom$xlim <- res$xlim
zoom$ylim <- res$ylim
+
+ updateNumericInput(session, "zoomYlimMin", value=res$ylim[1])
+ updateNumericInput(session, "zoomYlimMax", value=res$ylim[2])
# The event for replotting should be fired now
}
}
}, label="Zoom Out")
+ # zoom by numeric input fields
+ observe({
+# if(input$zoomYlimMin){
+# zoom$ylim[1] <- isolate(input$zoomYlimMin)
+# }
+# if(input$zoomYlimMax){
+# zoom$ylim[2] <- isolate(input$zoomYlimMax)
+# }
+ }, label="zoom by numeric input fields")
+
######################################################################################
## Reset function
observe({ # depends on zoom, input${whichLM, familyName, gridName}
Modified: branches/robast-1.0/pkg/RobExtremesBuffer/ui.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremesBuffer/ui.R 2015-11-09 10:10:50 UTC (rev 863)
+++ branches/robast-1.0/pkg/RobExtremesBuffer/ui.R 2015-11-09 12:52:05 UTC (rev 864)
@@ -5,12 +5,12 @@
fluidRow(
column(1,
radioButtons("gridName",
- label = "Grid auswählen",
+ label = "Grid auswählen",
choices = c("Sn", "OMSE", "RMXE", "MBRE")
),
radioButtons("familyName",
- label = "Familie auswählen",
+ label = "Familie auswählen",
choices = c("Generalized Pareto Family",
"GEV Family",
"GEVU Family",
@@ -21,17 +21,23 @@
), # column
column(3,
- # checkboxInput("withSmooth", label="Plot with Smooth"),
sliderInput("whichLM", label="L-Multiplikator auswählen", min=1, max=10, value=1),
checkboxInput("takeUsed", label="Gespeicherten Spline verwenden."),
- numericInput("df", "DF", 10),
+ numericInput("df", "DF", value=10, step=1),
selectInput("ranges", label="Glättung-Ausschluss-Intervalle", choices=NULL, size=10, selectize=FALSE),
- actionButton("deleteRange", label="Interval löschen"),
- fluidRow(
- column(6, actionButton("saveGrid", label="Speichere Grid (CSV)")),
- column(6, actionButton("addToHistory", label="Zu History hinzufügen"))
+ fluidRow(
+ column(5, actionButton("deleteRange", label="Interval löschen"))
+ ),
+
+ fluidRow(
+ column(5, actionButton("saveGrid", label="Speichere Grid (CSV)"))
+ ),
+
+ fluidRow(
+ column(5, actionButton("addToHistory", label="Zu History hinzufügen")),
+ column(5, actionButton("loadFromHistory", label="Aus History laden"))
)
), # column
@@ -42,7 +48,9 @@
),
fluidRow(
column(1, actionButton("zoomOut", label="Zoom Out", icon=icon("zoom-out", lib="glyphicon"))),
- column(2, offset=1, checkboxInput("withLegend", label="Legende anzeigen", value=TRUE))
+ column(2, offset=1, checkboxInput("withLegend", label="Legende anzeigen", value=TRUE)),
+ column(3, numericInput("zoomYlimMin", "Zoom ylim min", value=0.1)),
+ column(3, numericInput("zoomYlimMax", "Zoom ylim max", value=1.1))
)
) # column
) # fluidRow
Modified: branches/robast-1.0/pkg/RobExtremesBuffer/utilities.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremesBuffer/utilities.R 2015-11-09 10:10:50 UTC (rev 863)
+++ branches/robast-1.0/pkg/RobExtremesBuffer/utilities.R 2015-11-09 12:52:05 UTC (rev 864)
@@ -1,5 +1,5 @@
+source("config.R")
-
ranges.to.indicies <- function(ranges, values){
if (is.null(ranges))
return(NULL)
@@ -143,14 +143,14 @@
}
-load.file.to <- function(filePath, destEnvironment=new.env(),
- on.not.exist=function(filePath)stop("Fehler mit checkout"))
+loadRDataFileToEnv <- function(filePath, destEnvironment=new.env(),
+ onError=function(filePath)stop("Fehler mit checkout"))
{
## Loads an R data file into new environment
##
## Returns the environment with the data
if(!file.exists(filePath))
- return(on.not.exist(filePath))
+ return(onError(filePath))
# destEnvironment <- new.env()
load(filePath, envir=destEnvironment)
@@ -172,9 +172,9 @@
load.grids <- function(gridName, familyName, baseDir){
- # dataEnviron <- load.file.to(file.path(baseDir, "branches/robast-1.0/pkg/RobExtremesBuffer/sysdata.rda"))
- dataEnviron <- load.file.to("sysdata.rda")
- # dataEnviron <- load.file.to(file.path(baseDir, "branches/robast-1.0/pkg/RobAStRDA/R/sysdata.rda"))
+ # dataEnviron <- loadRDataFileToEnv(file.path(baseDir, "branches/robast-1.0/pkg/RobExtremesBuffer/sysdata.rda"))
+ dataEnviron <- loadRDataFileToEnv("sysdata.rda")
+ # dataEnviron <- loadRDataFileToEnv(file.path(baseDir, "branches/robast-1.0/pkg/RobAStRDA/R/sysdata.rda"))
return(loadGridsIntoEnv(dataEnviron, gridName, familyName))
}
@@ -433,29 +433,33 @@
return(NULL)
# store to history if the last differs from current
- if (can.push(zoomHistory, zoomList)){
- last.idx <- length(zoomHistory)
- zoomHistory[[last.idx + 1]] <<- zoomList
-
- # set new values
- res <- list (xlim=c(brush$xmin, brush$xmax), ylim=c(brush$ymin, brush$ymax))
- return(res)
- }
+ if (!can.push(zoomHistory, zoomList))
+ return(NULL)
- return(NULL)
+ idxOfLastEntry <- length(zoomHistory)
+ zoomHistory[[idxOfLastEntry + 1]] <<- zoomList
+
+ # set new values
+ res <- list(xlim=c(brush$xmin, brush$xmax), ylim=c(brush$ymin, brush$ymax))
+ return(res)
}
-zoom.out <- function(){
- idx.last <- length(zoomHistory)
- if(idx.last > 0){
- last <- zoomHistory[[idx.last]]
- zoomHistory <<- zoomHistory[1:(idx.last-1)]
-
- res <-list(xlim=c(last$xlim[1], last$xlim[2]), ylim=c(last$ylim[1], last$ylim[2]))
- return(res)
- }
- return(NULL)
+
+zoomOut <- function() {
+ idxOfLastEntry <- length(zoomHistory)
+ isHistoryEmpty <- idxOfLastEntry == 0
+
+ if(isHistoryNotEmpty)
+ return(NULL)
+
+ last <- zoomHistory[[idxOfLastEntry]]
+ zoomHistory <<- zoomHistory[1:(idxOfLastEntry-1)]
+
+ lims <- list(xlim=c(last$xlim[1], last$xlim[2]), ylim=c(last$ylim[1], last$ylim[2]))
+ return(lims)
}
+
+
delete.ranges <- function(whichLM, state.ranges, input.ranges){
if(!is.null(input.ranges) && (prev.deleted != input.ranges)){
res <- update.ranges.after.delete(allRanges=state.ranges[[whichLM]], which.to.delete=input.ranges)
@@ -487,17 +491,15 @@
# >>> [ranges]
# >>> [dfs]
###########################################################################
-local.commit.grid <- function(familyName, gridName, dfs, ranges){
- HISTORY_COMMITS_FILE <- "history.rda"
+addToHistory <- function(familyName, gridName, dfs, ranges, useExisting){
+ commitsEnv <- loadRDataFileToEnv(HISTORY_COMMITS_FILE, onError=function(x)new.env())
- commits.env <- load.file.to(HISTORY_COMMITS_FILE, on.not.exist=function(x)new.env())
-
# Get entry
gridLookupName <- getGridLookupName(gridName)
familyLookup <- getFamilyLookupName(familyName)
- if(exists(gridLookupName, envir=commits.env)){
- models <- get(gridLookupName, envir=commits.env)
+ if(exists(gridLookupName, envir=commitsEnv)){
+ models <- get(gridLookupName, envir=commitsEnv)
}else{
models <- list()
}
@@ -508,16 +510,59 @@
}
timestamp = format(Sys.time())
- models[[familyLookup]][[timestamp]] <- list(dfs=dfs, ranges=ranges)
+ models[[familyLookup]][[timestamp]] <- list(dfs=dfs, ranges=ranges, useExisting=useExisting)
- assign(gridLookupName, value=models, envir=commits.env)
+ assign(gridLookupName, value=models, envir=commitsEnv)
- names <- ls(commits.env, all.names=TRUE)
- save(list=names, file=HISTORY_COMMITS_FILE, envir=commits.env)
+ names <- ls(commitsEnv, all.names=TRUE)
+ save(list=names, file=HISTORY_COMMITS_FILE, envir=commitsEnv)
}
+loadDataFromHistory <- function(familyName, gridName) {
+ commitsEnv <- loadRDataFileToEnv(HISTORY_COMMITS_FILE, onError=function(x)new.env())
+
+ # Get entry
+ gridLookupName <- getGridLookupName(gridName)
+ familyLookup <- getFamilyLookupName(familyName)
+
+ if(exists(gridLookupName, envir=commitsEnv)){
+ models <- get(gridLookupName, envir=commitsEnv)
+ return(models[[familyLookup]])
+ }else{
+ return(NULL)
+ }
+
+ # append
+ if(is.null(models[[familyLookup]])){
+ return(NULL)
+ }
+
+}
+
+
+loadFromHistory <- function(familyName, gridName) {
+ data <- loadDataFromHistory(familyName, gridName)
+
+ timestamps <- names(data)
+ timestamps <- as.POSIXlt(timestamps)
+
+ latestTimestamp <- max(timestamps)
+
+ # Need again a string to be able to access the data
+ latestTimestamp <- as.character(latestTimestamp)
+ result <- data[[latestTimestamp]]
+ return(result)
+}
+
+
+hasHistory <- function(familyName, gridName) {
+ loadedHistory <- loadDataFromHistory(familyName, gridName)
+ return(!is.null(loadedHistory))
+}
+
+
checkRequiredPackages <- function(packages=REQUIRED_PACKAGES) {
inQuotes <- function(x) paste("\"", x, "\"", sep="")
@@ -533,3 +578,12 @@
stopApp()
}
}
+
+toogleAvailabilityComponents <- function(components, enable) {
+ if(enable){
+ sapply(components, function(x)shinyjs::enable(x))
+ } else {
+ sapply(components, function(x)shinyjs::disable(x))
+ }
+
+}
More information about the Robast-commits
mailing list