From noreply at r-forge.r-project.org Tue Sep 8 20:25:17 2015 From: noreply at r-forge.r-project.org (noreply at r-forge.r-project.org) Date: Tue, 8 Sep 2015 20:25:17 +0200 (CEST) Subject: [Robast-commits] r845 - branches/robast-1.0/pkg/RobExtremesBuffer Message-ID: <20150908182517.4BB2F187AED@r-forge.r-project.org> Author: ruckdeschel Date: 2015-09-08 20:25:16 +0200 (Tue, 08 Sep 2015) New Revision: 845 Added: branches/robast-1.0/pkg/RobExtremesBuffer/.RData branches/robast-1.0/pkg/RobExtremesBuffer/.Rhistory 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: [internal] committed Eugen's routine for LM - Smoothing Added: branches/robast-1.0/pkg/RobExtremesBuffer/.RData =================================================================== (Binary files differ) Property changes on: branches/robast-1.0/pkg/RobExtremesBuffer/.RData ___________________________________________________________________ Added: svn:mime-type + application/octet-stream Added: branches/robast-1.0/pkg/RobExtremesBuffer/.Rhistory =================================================================== --- branches/robast-1.0/pkg/RobExtremesBuffer/.Rhistory (rev 0) +++ branches/robast-1.0/pkg/RobExtremesBuffer/.Rhistory 2015-09-08 18:25:16 UTC (rev 845) @@ -0,0 +1,434 @@ +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("Durch ??ndern der Grid & Familie, gehen alle nicht-gespeicherte Intervalle verloren.") +## 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() Added: branches/robast-1.0/pkg/RobExtremesBuffer/config.R =================================================================== --- branches/robast-1.0/pkg/RobExtremesBuffer/config.R (rev 0) +++ branches/robast-1.0/pkg/RobExtremesBuffer/config.R 2015-09-08 18:25:16 UTC (rev 845) @@ -0,0 +1,18 @@ +# ROBAST_BASE_DIR = if ("massini" == Sys.info()['login']){ +# paste0( +# if(.Platform$OS.type=="windows") "P:" else "/p/fm", +# "/EugenMassini/robast" +# ) +# }else{ +# "C:/rtest/RobASt" +# } +# +# +# # INTERPOLATION_DIR <- "branches/robast-1.0/pkg/RobExtremes/inst/AddMaterial/interpolation" +# # INTERPOLATION_FILE <- "plotInterpol.R" +# +# INTERPOLATION_DIR <- "branches/robast-1.0/pkg/RobExtremesBuffer" +# INTERPOLATION_FILE <- "plotInterpolSimple.R" + + +TEST.save.grid <- TRUE \ No newline at end of file Added: branches/robast-1.0/pkg/RobExtremesBuffer/server.R =================================================================== --- branches/robast-1.0/pkg/RobExtremesBuffer/server.R (rev 0) +++ branches/robast-1.0/pkg/RobExtremesBuffer/server.R 2015-09-08 18:25:16 UTC (rev 845) @@ -0,0 +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("Durch ?ndern der Grid & Familie, gehen alle nicht-gespeicherte Intervalle verloren.") + + ## 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=","))) [TRUNCATED] To get the complete diff run: svnlook diff /svnroot/robast -r 845