[Robast-commits] r848 - branches/robast-1.0/pkg/RobExtremesBuffer
noreply at r-forge.r-project.org
noreply at r-forge.r-project.org
Thu Nov 5 11:06:55 CET 2015
Author: bspangl
Date: 2015-11-05 11:06:54 +0100 (Thu, 05 Nov 2015)
New Revision: 848
Modified:
branches/robast-1.0/pkg/RobExtremesBuffer/server.R
Log:
Aenderung Umlaut
Modified: branches/robast-1.0/pkg/RobExtremesBuffer/server.R
===================================================================
--- branches/robast-1.0/pkg/RobExtremesBuffer/server.R 2015-11-04 14:24:03 UTC (rev 847)
+++ branches/robast-1.0/pkg/RobExtremesBuffer/server.R 2015-11-05 10:06:54 UTC (rev 848)
@@ -1,464 +1,464 @@
-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)
- }
- }
- })
-})
+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 aendern 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),
[TRUNCATED]
To get the complete diff run:
svnlook diff /svnroot/robast -r 848
More information about the Robast-commits
mailing list