modelParams.R

model <- list()
#*********************************************************

#
model$savory$creamcheese$wheat$beta <- 1
model$savory$creamcheese$wheat$alpha <- 2
model$savory$creamcheese$wheat$gamma <- 3
#
model$savory$creamcheese$raisin$beta <- 4
model$savory$creamcheese$raisin$alpha <- 5
model$savory$creamcheese$raisin$gamma <- 6

#
model$savory$lox$poppy$beta <- 7
model$savory$lox$poppy$alpha <- 8
model$savory$lox$poppy$gamma <- 9

#
model$savory$lox$sesame$beta <- 8
model$savory$lox$sesame$alpha <- 7
model$savory$lox$sesame$gamma <- 6

#
model$savory$butter$poppy$beta <- 5
model$savory$butter$poppy$alpha <- 4
model$savory$butter$poppy$gamma <- 3

#
model$savory$butter$wheat$beta <- 2
model$savory$butter$wheat$alpha <- 1
model$savory$butter$wheat$gamma <- 1

#
model$salty$bacon$toasted$beta <- 2
model$salty$bacon$toasted$alpha <- 3
model$salty$bacon$toasted$gamma <- 4

#
model$salty$bacon$untoasted$beta <- 5
model$salty$bacon$untoasted$alpha <- 6
model$salty$bacon$untoasted$gamma <- 7

#
model$sweet$jelly$white$beta <- 6
model$sweet$jelly$white$alpha <- 5
model$sweet$jelly$white$gamma <- 4

#
model$sweet$jelly$muffin$beta <- 3
model$sweet$jelly$muffin$alpha <- 2
model$sweet$jelly$muffin$gamma <- 1

#
model$sweet$jam$white$beta <- 7
model$sweet$jam$white$alpha <- 11
model$sweet$jam$white$gamma <- 13

#
model$sweet$jam$muffin$beta <- 1
model$sweet$jam$muffin$alpha <- 3
model$sweet$jam$muffin$gamma <- 5

server.R

library(shiny)
library(shinyURL)

source("modelParams.R")

renderSelect = function(n, output, input) {
  sec = paste0("sec", n)
  topLev = paste0("topLev", n)
  secondLev = paste0("secondLev", n)
  
  output[[sec]] <- renderUI({
    selectInput(inputId = secondLev,
                label = "select second level",
                choices = names(model[[input[[topLev]]]])
    )
  })
  outputOptions(output, sec, suspendWhenHidden = FALSE)
  
  thrd = paste0("thrd", n)
  thirdLev = paste0("thirdLev", n)
  output[[thrd]] <- renderUI({
    req(input[[secondLev]])
    selectInput(inputId = thirdLev,
                label = "select third level",
                choices = names(model[[input[[topLev]]]][[input[[secondLev]]]])
    )
  })
  outputOptions(output, thrd, suspendWhenHidden = FALSE)
}

shinyServer(function(input, output, session) {
  shinyURL.server(session)
  
  modelCalc <- function(temp,area,model)
  {
    hrs <- seq(from =0, to = 2, by = 0.05)
    F <- area*(model$alpha) + hrs*(model$beta)^3 + exp(model$gamma*(temp/100)*hrs)
    list(F = F, hrs = hrs)
  }
  
  for (n in 1:4) renderSelect(n, output, input)
  
  output$modelPlot <- renderPlot({
    temp <- lapply(paste0("temp",1:as.numeric(input$nTraces)), function(x) input[[x]])
    
    area <- lapply(paste0("area",1:as.numeric(input$nTraces)), function(x) input[[x]])
    
    modelStr <- c("topLev", "secondLev", "thirdLev")
    modelCall <- lapply(1:as.numeric(input$nTraces), function(n) paste0(modelStr,n))
    modelIn <- lapply(modelCall,function(x) model[[input[[x[1]]]]][[input[[x[2]]]]][[input[[x[3]]]]])
    mLegendStr <- lapply(modelCall, function(x) paste(input[[x[1]]],input[[x[2]]],input[[x[3]]]))
    
    modelOut <- list()
    if(input$nTraces == '1')
    {
      modelOut <- modelCalc(area=area[[1]],temp=temp[[1]],model=modelIn[[1]])
    } else
    {
      modelOut <- switch(input$parVary,
                         "model" = lapply(modelIn,modelCalc,area=area[[1]],temp=temp[[1]]),
                         "temp" = lapply(temp,modelCalc,area=area[[1]],model=modelIn[[1]]),
                         "area" = lapply(area,modelCalc,temp=temp[[1]],model=modelIn[[1]])
      )
    }
    
    if(input$nTraces =='1')
    {
      modelOut_flat <- unlist(modelOut)
    } else
    {
      modelOut_flat <- unlist(lapply(modelOut,unlist,recursive=FALSE))
    }
    colorVec <- c('red','blue','green','cyan','magenta','black')
    F_flat <- modelOut_flat[grep("^F",names(modelOut_flat))]
    hrs_flat <- modelOut_flat[grep("^hrs",names(modelOut_flat))]
    ylim_v <- range(F_flat[F_flat>0])
    xlim_h <- range(hrs_flat[hrs_flat>0])
    
    if(input$nTraces == '1')
    {
      plot(modelOut$hrs[modelOut$F>0],modelOut$F[modelOut$F>0],
           log="xy",pch=1, col=colorVec[1],
           xlab="Time [hrs]", ylab="Model output",'o',
           ylim=ylim_v,xlim=xlim_h)
    } else
    {
      plot(modelOut[[1]]$hrs[modelOut[[1]]$F>0],modelOut[[1]]$F[modelOut[[1]]$F>0],
           log="xy",pch=1, col=colorVec[1],
           xlab="Time [hrs]",ylab="Model output",'o',
           ylim=ylim_v,xlim=xlim_h)
    }
    grid(col="blue")
    if(input$nTraces != '1')
    {
      for(i in 2:length(modelOut)) {
        points(modelOut[[i]]$hrs[modelOut[[i]]$F>0],modelOut[[i]]$F[modelOut[[i]]$F>0],
               pch=1,col=colorVec[i],'o')
        
      }
    }
    
    leg.names <- switch(input$parVary,
                        "temp" = sprintf('Temp=%.0f C',temp),
                        "area" = sprintf('Area=%.2e um^2',area),
                        "model"= sprintf('model=%s',mLegendStr)
    )
    legend("topleft",leg.names,bg="white",pch=1,lty=1,col=colorVec)
    
    par(ps=11)
    titleRet <-  switch(input$parVary,
                        "temp" = title(sprintf("%s %s %s MODEL; Area=%.2eum^2", input$topLev1,input$secondLev1,input$thirdLev1,area[[1]])),
                        "area" = title(sprintf("%s %s %s MODEL; temp=%.0fC", input$topLev1,input$secondLev1,input$thirdLev1,temp[[1]])),
                        "model"= title(sprintf("MODEL; temp=%.0fC; Area=%.2eum^2", temp[[1]],area[[1]]))
    )
  })
  
  inputs = c(
    "nTraces", "parVary",
    "topLev1", "secondLev1", "thirdLev1", "temp1", "area1",
    "topLev2", "secondLev2", "thirdLev2", "temp2", "area2",
    "topLev3", "secondLev3", "thirdLev3", "temp3", "area3")
  
  output$textDisplay <- renderTable({
    available = reactiveValuesToList(input)
    names = names(available)
    getMat = as.matrix(sapply(inputs, function(name) if (name %in% names) available[[name]] else NA))
    colnames(getMat) = c("Value")
    getMat
  })
})

ui.R

library(shiny)
library(shinyURL)

source("modelParams.R")

topLevel <- names(model)

conditionalPanels = function(n) { 
  tagList(
    conditionalPanel(
      condition = "input.parVary == 'model'",
        selectInput(inputId = paste0("topLev", n),
                    label = "select top level",
                    choices = topLevel),
      uiOutput(paste0("sec", n)),
      uiOutput(paste0("thrd", n))
    ),
    conditionalPanel(
      condition = "input.parVary == 'area'",
      numericInput(inputId = paste0("area", n),
                   label = "Total gate area (um^2)",
                   min = 1, max = 10, value = 5)
    ),
    conditionalPanel(
      condition = "input.parVary == 'temp'",
      sliderInput(inputId = paste0("temp", n),
                  label = "Temperature (C)",
                  min = 85, max = 125, value = 0, step = 5)
    )
  )
}

shinyUI(pageWithSidebar(
  
  headerPanel("URL conditional setting example"),
  
  sidebarPanel(
    tabsetPanel(id = "tab",
      tabPanel("setup",
               radioButtons(inputId = "nTraces",
                            label = "multiple trace, single parameter variation ",
                            choices = list("single trace" = 1, "2 traces" = 2, "3 traces" = 3, "4 traces" = 4)),
               selectInput(inputId = "topLev1",
                           label = "select top Level",
                           choices = topLevel),
               uiOutput("sec1"),
               uiOutput("thrd1"),
               numericInput(inputId = "area1",
                            label = "Total gate area (um^2)",
                            min = 1, max = 10, value = 5),
               sliderInput(inputId = "temp1",
                           label = "Temperature (C)",
                           min = 85, max = 125, value = 125, step = 5)
      ),
      tabPanel("trace 2",
               conditionalPanel(
                 condition = "input.nTraces == '2' || input.nTraces == '3' || input.nTraces == '4'",
                 radioButtons(inputId = "parVary",
                              label = "choose single parameter variation ",
                              choices = list("model" = "model",  "area" = "area", "temperature" = "temp")
                 ),
                 conditionalPanels(2)
               )
      ),
      tabPanel("trace 3",
               conditionalPanel(
                 condition = "input.nTraces == '3' || input.nTraces == '4'",
                 conditionalPanels(3)
               )
      ),
      tabPanel("trace 4",
               conditionalPanel(
                 condition = "input.nTraces == '4'",
                 conditionalPanels(4)
               )
      ),
      shinyURL.ui(tinyURL = FALSE)
    )
  ),
  
  mainPanel(
    tabsetPanel(id = "main",
      tabPanel("Output and data type", tableOutput("textDisplay")),
      tabPanel("Model plots", plotOutput("modelPlot"))
    )
  )
))