Nothing
#' Generate Server Part of SPOT-GUI
#'
#' Generates the server part of the SPOT-GUI.
#' This method is used internally in the starting process of the GUI.
#' Manual use of this function is not advised.
#'
#' @param input shiny UI-input
#' @param output shiny UI-output
#' @param session shiny UI-session
#' @export
getServer <- function(input, output, session) {
initVariables <- function(init){
doeWasLast(T)
spotResult(NULL)
tableChangedByScript(F)
rLogOutput(rLogResetMessage())
if(init){
shinyjs::disable("resetData")
#shinyjs::disable("evaluateData")
shinyjs::disable("proposeNewPoint")
shinyjs::enable("runCreateDOE")
shinyjs::enable("runSpotIter")
}
}
#initialization
doeWasLast <- reactiveVal()
tableChangedByScript <- reactiveVal()
spotResult <- reactiveVal()
rLogOutput <- reactiveVal()
setEnvData("inputDimensions", NULL)
maxInputDimension <- reactiveVal(0)
configInitiated <- reactiveVal(FALSE)
initVariables(FALSE)
#This list is used to reset all data if changes are made to the fitness function definition
listObjectiveFunctionElements <- reactive(list(
input$objectiveFunction
))
## En-/Disables
#shinyjs::disable("evaluateData")
shinyjs::disable("resetData")
shinyjs::disable("proposeNewPoint")
shinyjs::disable("runCreateDOE")
shinyjs::disable("runSpotIter")
shinyjs::disable("interruptSpot")
## Events
observeEvent(input$runCreateDOE,{
if(is.null(input[["xml_designLHDcontrolreplicates"]])){
showModal(modalDialog(title="Load Error",
"Spot Config was not fully loaded, please revisit Spot Config tab"))
return()
}
if(!input$objectiveFunction == "mInput"){
if(!checkInputCorrectness(input)){
return()
}
}
if(getNDim(input) == 0){
showModal(modalDialog(title="Configuration Error","You have to specify at least one
input dimension before you can do this!"
,footer=NULL,easyClose=T))
return()
}
if(!input$rLogMode){
shinyjs::disable("runCreateDOE")
shinyjs::disable("runSpotIter")
tryCatch(expr = {
spotResult(createDOE(input, spotResult()))}
, error = function(cond) {
showModal(modalDialog(title="Configuration Error",HTML(paste("There seems to be an error in your configuration.<br>
SPOT was not able to run.<br>
Please check for typos/misconfigurations
in the SPOT Config Tab<br><br>Original spot error was:<br>",cond))
,footer=NULL,easyClose=T))
shinyjs::enable("runCreateDOE")
shinyjs::enable("runSpotIter")
return()
})
configInitiated(TRUE)
shinyjs::enable("evaluateData")
shinyjs::enable("resetData")
doeWasLast(T)
}else{
showModal(modalDialog(title="Added Log Entry","Your action was logged into the export menu."
,footer=NULL,easyClose=T))
}
rLogOutput(paste0(rLogOutput(),generateTextDOECreation(input, spotResult())))
})
observeEvent(input$evaluateData,{
req(spotResult())
if(!input$objectiveFunction == "mInput"){
if(!checkInputCorrectness(input)){
return()
}
}
localResult <- spotResult()
x <- localResult$x
#browser()
colnames(localResult$x) <- paste0("X",1:ncol(x))
y <- localResult$y
if(input$objectiveFunction == "mInput"){
if(any(is.na(y)) | nrow(x) > length(y)){
showModal(modalDialog(title="Missing Data",
"Please fill the result column before fitting a model!"
,footer=NULL,easyClose=T))
return()
}
tryCatch(expr = {
localResult$modelFit <- buildModel(input,localResult)}
, error = function(cond) {
showModal(modalDialog(title="Configuration Error",
HTML(paste("There seems to be an error in your configuration.<br>
There might be an issue in the configuration of your objective function<br>
or there exists a wrong entry in the data table.<br>
Please check for typos/misconfigurations
<br><br>Original error message was:<br>",cond))
,footer=NULL,easyClose=T))
return()
})
}else{
if(!input$rLogMode){
tryCatch(expr = {
fun <- getObjectiveFunction(input)
localResult$y <- evaluateMissingCandidateSolutions(x,y,fun)
localResult$modelFit <- buildModel(input,localResult)}
, error = function(cond) {
showModal(modalDialog(title="Configuration Error",
HTML(paste("There seems to be an error in your configuration.<br>
There might be an issue in the configuration of your objective function<br>
or there exists a wrong entry in the data table.<br>
Please check for typos/misconfigurations
<br><br>Original error message was:<br>",cond))
,footer=NULL,easyClose=T))
return()
})
}
}
rLogOutput(paste0(rLogOutput(),generateTextEvaluation(input)))
if(!input$rLogMode){
spotResult(localResult)
shinyjs::enable("runCreateDOE")
shinyjs::enable("runSpotIter")
shinyjs::enable("resetData")
shinyjs::enable("proposeNewPoint")
}else{
showModal(modalDialog(title="Added Log Entry","Your action was logged into the export menu."
,footer=NULL,easyClose=T))
}
})
observeEvent(input$runSpotIter, {
if(is.null(input[["xml_designLHDcontrolreplicates"]])){
showModal(modalDialog(title="Load Error",
"Spot Config was not fully loaded, please revisit Spot Config tab"))
return()
}
if(input$objectiveFunction == "mInput"){
showModal(modalDialog(title="Manual Mode",
"Running SPOT automatically is not possible in Manual Mode.
Please configure an objective function in the objective function menu."
,footer=NULL,easyClose=T))
return()
}
if(!checkInputCorrectness(input)){
return()
}
if(getNDim(input) == 0){
showModal(modalDialog(title="Configuration Error","You have to specify at least one
input dimension before you can do this!"
,footer=NULL,easyClose=T))
return()
}
rLogOutput(paste0(rLogOutput(),generateTextSpotCall(input, spotResult())))
if(!input$rLogMode){
shinyjs::disable("runSpotIter")
shinyjs::enable("interruptSpot")
session <- shiny::getDefaultReactiveDomain()
localSpotResult <- spotResult()
tryCatch(expr = {
ctrl <- getSpotControl(input)
funEvals <- ctrl$funEvals
stepsTodo <- funEvals - max(ctrl$designControl$size,length(localSpotResult$y)) + 1
bounds <- getBounds(input)
withProgress(message = 'Calculation in progress', {
while(T){
if(isTRUE(session$input$spotInterrupted)){
break
}
if(!is.null(localSpotResult)){
if(nrow(localSpotResult$x) >= funEvals){
break
}
}
localSpotResult <- doSpotIter(input,localSpotResult,ctrl,bounds)
incProgress(1/stepsTodo)
}
})
}, error = function(cond) {
showModal(modalDialog(title="Configuration Error",HTML(paste("There seems to be an error in your configuration.<br>
SPOT was not able to run.<br>
Please check for typos/misconfigurations
in the SPOT Config Tab<br><br>Original spot error was:<br>",cond))
,footer=NULL,easyClose=T))
shinyjs::enable("runSpotIter")
return()
})
spotResult(localSpotResult)
shinyjs::disable("interruptSpot")
shinyjs::enable("runSpotIter")
shinyjs::enable("resetData")
shinyjs::enable("evaluateData")
shinyjs::enable("proposeNewPoint")
doeWasLast(F)
}else{
showModal(modalDialog(title="Added Log Entry","Your action was logged into the export menu."
,footer=NULL,easyClose=T))
}
})
observeEvent(input$resetData,{
rLogOutput(paste0(rLogOutput(),rLogResetMessage()))
initVariables(configInitiated())
})
observeEvent(input$resultTable,{
if(!tableChangedByScript()){
newData <- as.matrix(hot_to_r(input$resultTable))
newResult <- spotResult()
newResult$x <- newData[,1:getNDim(input)]
newResult$y <- newData[,ncol(newData)]
spotResult(newResult)
}
tableChangedByScript(F)
})
observeEvent(input$resultTableIE,{
if(!tableChangedByScript()){
newData <- as.matrix(hot_to_r(input$resultTableIE))
newResult <- spotResult()
newResult$x <- newData[,1:getNDim(input)]
newResult$y <- newData[,ncol(newData)]
spotResult(newResult)
}
tableChangedByScript(F)
})
## Objective Function Settings changes lead to calculation reset
observeEvent(listObjectiveFunctionElements(),{
initVariables(configInitiated())
})
observeEvent(input$proposeNewPoint,{
req(spotResult())
if(!input$objectiveFunction == "mInput"){
if(!checkInputCorrectness(input)){
return()
}
}
if(any(is.na(spotResult()$y)) | nrow(spotResult()$x) > length(spotResult()$y)){
showModal(modalDialog(title="Missing Data",
"Please fill the result column before generating new design points!"
,footer=NULL,easyClose=T))
return()
}
if(!input$rLogMode){
shinyjs::disable("runSpotIter")
tryCatch(expr = {
localResult <- spotResult()
model <- localResult$modelFit
optimizer <- get(getOptimizer(input))
optimizerControl <- getControlList(input,"optimizer")
fun <- evaluateModel(model)
bounds <- getBounds(input)
bestPoint <- optimizer(fun = fun, lower = bounds[[1]], upper = bounds[[2]],control = optimizerControl)
localResult$x <- rbind(localResult$x,bestPoint$xbest)
spotResult(localResult)}
, error = function(cond) {
showModal(modalDialog(title="Configuration Error",HTML(paste("There seems to be an error in your configuration.<br>
SPOT was not able to run.<br>
Please check for typos/misconfigurations
in the SPOT Config Tab<br><br>Original spot error was:<br>",cond))
,footer=NULL,easyClose=T))
return()
})
}else{
showModal(modalDialog(title="Added Log Entry","Your action was logged into the export menu."
,footer=NULL,easyClose=T))
}
rLogOutput(paste0(rLogOutput(),generateTextNewPoint(input)))
})
observeEvent(input$addDimension,{
maxInputDimension(maxInputDimension() + 1)
insertUI(
selector = '#objectiveFunctionInputParameters',
where = "beforeEnd",
ui = createDimensionElement(input,
NULL,
maxInputDimension(),
initVariables,
configInitiated))
initVariables(configInitiated())
})
############## test
output$clipButton <- renderUI({
if (requireNamespace("rclipboard", quietly = TRUE)) {
rclipButton("clipbtn", "Copy to Clipboard", rLogOutput(), icon("clipboard"))
} else {
showModal(modalDialog(title="Package Missing","This feature requires the rclipboard package."
,footer=NULL,easyClose=T))
}
})
output$variableSelectors <- renderUI({
req(spotResult()$y)
getPlotSelectorButtonList(input,"AUTO")
})
output$slidersResult <- renderUI({
req(spotResult()$y)
req(input$selectorXAUTO)
do.call(tagList, getPlotSliderList(input,"AUTO"))
})
output$resultModelPlot <- renderPlotly({
req(spotResult()$y)
validate(
need(getNDim(input) >= 2, "Plots are currently only possible with >= 2 Dimensions")
)
# Require that at least one slider exists if input dimensions is larger 2
if(getNDim(input)> 2){
val <- getNotSelectedVariables(input,"AUTO")[1]
req(input[[paste("sliderAUTOx",val,sep="")]])
}
model <- spotResult()$modelFit
if(is.null(model)){
return()
}
if(is.na(model[1])){
return()
}
if(getNDim(input) == 2){
#plotModel(model,type ="filled.contour")
p <- plotModel(model,type ="persp3d")
p$elementId <- NULL
p
}else{
variables = 1:getNDim(input)
variables = variables[-getNotSelectedVariables(input, "AUTO")]
sliderInputs <- getPlotSliderValues(input,"AUTO")
p <- plotModel(model,
which = variables, constant = sliderInputs,type ="persp3d")
p$elementId <- NULL
p
}
})
round_df <- function(df, digits) {
nums <- as.vector(is.na(df))
if(length(nums) == 0){
return(df)
}
for(i in 1:length(nums)){
if(!nums[i]){
row <- i%%nrow(df)
if(row == 0){
row <- nrow(df)
}
col <- as.integer(i/nrow(df))+1
if(row == nrow(df)){
col <- col -1
}
df[row,col] <- round(df[row,col], digits = digits)
}
}
for(i in 1:ncol(df)){
df[,i] <- as.numeric(df[,i])
}
df
}
output$resultTable <- renderRHandsontable({
req(spotResult())
tableChangedByScript(T)
x <- spotResult()$x
y <- spotResult()$y
if(length(dim(x)) > 1){
len <- nrow(x)
}else{
len <- length(x)
}
if(len == length(y)){
data <- cbind(x,y)
}else{
data <- cbind(x,c(y,rep(NA,nrow(x)-length(y))))
}
colNames <- NULL
for(i in 1:(ncol(data)-1)){
colNames <- c(colNames, paste("x",i,sep=""))
}
colNames <- c(colNames, "results")
df <- data.frame(data)
names(df) <- colNames
df <- round_df(df,3)
rhandsontable(df, stretchH = "all")
})
output$resultTableIE <- renderRHandsontable({
req(spotResult())
tableChangedByScript(T)
x <- spotResult()$x
y <- spotResult()$y
if(length(dim(x)) > 1){
len <- nrow(x)
}else{
len <- length(x)
}
if(len == length(y)){
data <- cbind(x,y)
}else{
data <- cbind(x,c(y,rep(NA,nrow(x)-length(y))))
}
colNames <- NULL
for(i in 1:(ncol(data)-1)){
colNames <- c(colNames, paste("x",i,sep=""))
}
colNames <- c(colNames, "results")
df <- data.frame(data)
names(df) <- colNames
df <- round_df(df,3)
rhandsontable(df, stretchH = "all")
})
output$bestFound <- renderUI({
req(spotResult()$y)
req(nrow(spotResult()$x)==length(spotResult()$y))
getTextoutputBestSolution(input,cbind(spotResult()$x,spotResult()$y))
})
output$rLog <- renderText({
if(!input$shortenLog){
rLogOutput()
}else{
outText <- rLogOutput()
if(grepl("## Data Reset\n",outText)){
splits <- strsplit(outText,"## Data Reset\n", fixed=T)[[1]]
outText <- splits[[length(splits)]]
}
outText
}
})
output$fieldOptimizerSelector <- renderUI({
getUiSelectorXML("optimizer",input)
})
output$optimizerUI <- renderUI({
req(input$optimizerSelector)
getUiXML("optimizer",input)
})
output$fieldModelSelector <- renderUI({
getUiSelectorXML("model",input)
})
output$modelUI <- renderUI({
req(input$modelSelector)
getUiXML("model",input)
})
output$fieldDesignSelector <- renderUI({
shinyjs::enable("runCreateDOE")
shinyjs::enable("runSpotIter")
getUiSelectorXML("design",input)
})
spotResultToDF <- function(){
localResult <- spotResult()
if(is.null(localResult)){
return()
}
x <- localResult$x
y <- localResult$y
if(length(dim(x)) > 1){
len <- nrow(x)
}else{
len <- length(x)
}
if(len == length(y)){
data <- cbind(x,y)
}else{
data <- cbind(x,c(y,rep(NA,nrow(x)-length(y))))
}
colNames <- NULL
for(i in 1:(ncol(data)-1)){
colNames <- c(colNames, paste("x",i,sep=""))
}
colNames <- c(colNames, "results")
df <- data.frame(data)
names(df) <- colNames
df
}
observeEvent(c(input$removeEmptyTableRows,input$removeEmptyTableRowsIE),{
localResult <- spotResult()
df <- spotResultToDF()
if(is.null(df)){
return()
}
ind <- NULL
for(i in 1:nrow(df)){
row <- df[i,]
if(all(is.na(row))){
ind <- c(ind, i)
}
}
if(!is.null(ind)){
df <- df[-ind,]
}
localResult$x <- df[,-ncol(df)]
localResult$y <- df[,ncol(df)]
if(length(localResult$y) == 0){
spotResult(NULL)
}
spotResult(localResult)
})
#observeEvent(input$exportData,{
# localResult <- spotResult()
# if(is.null(localResult)){
# showModal(modalDialog(title="Export Error",
# "There was no data to export"))
# return()
# }
# volumes <- c("UserFolder"="~/")
# shinyFiles::shinyFileSave(input, "exportData", roots=volumes, session=session)
# fileinfo <- shinyFiles::parseSavePath(volumes, input$exportData)
# df <- spotResultToDF()
# if (nrow(fileinfo) > 0) {
# utils::write.csv(df, as.character(fileinfo$datapath), row.names = F)
# }
#})
output$downloadData <- downloadHandler(
filename = function() {
paste('data-', Sys.Date(), '.csv', sep='')
},
content = function(con) {
localResult <- spotResult()
if(is.null(localResult)){
showModal(modalDialog(title="Export Error",
"There was no data to export"))
return()
}
df <- spotResultToDF()
utils::write.csv(df, con, row.names = F)
})
observeEvent(input$importData,{
req(input$importData)
data <- utils::read.csv(input$importData$datapath)
localResult <- spotResult()
localResult$x <- unname(as.matrix(data[,-ncol(data)]))
localResult$y <- data[,ncol(data)]
spotResult(localResult)
shinyjs::enable("resetData")
shinyjs::enable("evaluateData")
})
observeEvent(c(input$addTableRow,input$addTableRowIE),{
localResult <- spotResult()
if(is.null(localResult$x)){
localResult$x <- matrix(rep(NA,getNDim(input)), ncol = getNDim(input))
}else{
localResult$x <- rbind(localResult$x, rep(NA,getNDim(input)))
localResult$y <- c(localResult$y,NA)
}
spotResult(localResult)
})
output$designUI <- renderUI({
req(input$designSelector)
getUiXML("design",input)
})
output$spotConfigUI <- renderUI({
getUiXML("general",input, selectedInput = "general"
, selectedElement = getSelectedElementList("general", "general", input))
})
output$objectiveFunctionSelector <- renderUI({
getObjectiveFunctionSelectorXML(input)
})
output$objectiveFunctionInputParameters <- renderUI({
req(input$objectiveFunction)
req(input$smoofFunctionSelector)
isolate(
maxInputDimension(maxInputDimension() +
generateInputUI(input, initVariables,configInitiated)))
div()
})
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.