Dynamic Slider creation

shiny
,
1

Guys,

need help in figuring out a way to add dynamic slider filters to my page but the sliders are created from by UIoutput and when i run the code i get a "No handler registered for type 222v04rpcp:ti222302a.pnt". below is the sample code, please let me know if someone can help me figure this out.

library(shiny)
library(plotly)
library(caret)
library(readxl)



ui  <- fluidPage(
  # shinythemes::themeSelector(),
  tags$head(tags$style(
    type = 'text/css',
    'form.well { max-height: 600px; overflow-y: auto; }'
  )),
  # App title ----
  titlePanel("RHC simulator"),
  
  # Sidebar layout with input and output definitions ----
  sidebarLayout(
    
    # Sidebar panel for inputs ----
    sidebarPanel(
      
      # Input: Select a file ----
      fileInput("file1", "Choose RHC File",
                multiple = TRUE,
                accept = c("text/csv",
                           "text/comma-separated-values,text/plain",
                           ".csv",
                           ".Xlsx")),
      uiOutput("sliders"),
      actionButton("update", "Go!", icon('paper-plane'),style="color: #fff; background-color: #337ab7; border-color: #2e6da4"),
      checkboxInput('smooth','Apply smoothing (may help in the presence of extreme values and outliers)', FALSE),
      downloadButton('downloadpred', 'Download'),
      br(), br(),
      helpText(paste('Last updated',
                     file.info('app.R')$mtime)),
      helpText(
        "For more information on this tool, please contact",
        a(href="mailto:Ming.Zhong@shell.com", target="_blank", "Ming")
      )
      ),

    # Main panel for displaying outputs ----
    mainPanel(
      tabsetPanel(
        tabPanel('Model1',
                 # h4('The following predictors are included in the imbeded-trained-parsimonious-dangerous-tedious model'),
                 # verbatimTextOutput("info1"),
                 plotlyOutput("pltpred")
        ),
        tabPanel('Model2',
                 # h4('The following predictors are included in the imbeded-trained-full-exhaustive model'),
                 # verbatimTextOutput("info2"),
                 plotlyOutput("pltpred2")
        ),
      tabPanel('Data',
               # Output: Data file ----
               DT::dataTableOutput("contents"),
               plotlyOutput("pltvar")
               )
    )
    ) 
  )
)



server  <- function(input, output, session) {
  
  ax <- list(
    title = "",
    zeroline = FALSE,
    showline = FALSE,
    showticklabels = FALSE,
    showgrid = FALSE
  )
  
  models <- if (.Platform$OS.type == "windows") {
    readRDS("C:/Users/P.Alavala/Desktop/RHC_ML_models_APR2018.rds")
    # readRDS("E:/RHC/data/RHC_models.rds")
  } else {
    readRDS('./data/RHC_models_FEB2018.rds')
    # readRDS('./data/RHC_models.rds')
  }
  

  data <- reactive({
    req(input$file1)
    df <- read_xlsx(input$file1$datapath)
    revnames <- paste0('X_',gsub('[^A-Za-z0-9]',"_", names(df)))
    
    validate(
      need(try(if (grepl('/', df$From_Date[1]))
        as.Date(df$From_Date[1], '%m/%d/%Y')
        else
          as.Date(df$From_Date[1])), 
        "Please check date format, either 2018-01-15 or 01/15/2018"),
      need(all(predictors(models[[2]]) %in% names(df))|
             all(predictors(models[[2]]) %in% revnames),
           paste0('Input data need to contain required variables. The following variables are needed to run model: \n', 
                  paste(setdiff(predictors(models[[2]]), 
                                names(df)), collapse ='\n')))
    )
    
    if (grepl('/', df$From_Date[1]))
      df$From_Date <- as.Date(df$From_Date, '%m/%d/%Y')
    else
      df$From_Date <- as.Date(df$From_Date)
    
    pvars <- intersect(predictors(models[[2]]), 
                     names(df))
    
    # update df with sliders
    df1   <- df
    df1[,pvars] <- data.frame(sapply(pvars,
                                     function(x)
                                       df[[x]]*(1+input[[x]]/100)))
    if (input$smooth) {
      df1[,pvars] <- data.frame(sapply(pvars,
                                       function(x)
                                         as.numeric(smooth(df1[[x]]))))
    }
    
    lapply(seq(pvars), function(i) {
      updateSliderInput(session, 
                        pvars[i], 
                        value = input[[pvars[i]]])
    })
    
    plts <- lapply(pvars, function(var) {
      plot_ly(df1) %>%
        add_trace(x = ~ From_Date ,
                  y = ~ get(var),
                  type = 'scatter',
                  mode = 'lines',
                  name = var) %>%
        layout(xaxis = list(title='From_Date'),
               yaxis = list(title=var))
    })
    
    list(df=df,
         df1=df1,
         pvars=pvars,
         plts=plts)
  })  
  
  output$sliders <- renderUI({
    pvars <- data()$pvars
    
    slider_list <- lapply(seq(pvars), function(i) {
      sliderInput(inputId = pvars[i],
                  label = pvars[i],
                  min = -20,
                  max = 20,
                  post = '%',
                  value = 0)
    })
    
    do.call(tagList, slider_list)

  })

  
}

shinyApp(ui = ui, server = server)
2

You'll have to find a way to simplify the inputId, as pvars[i] contains colon and period which are not allowed.

3

Cheng,

Is there a sample code you can provide that simplifies the inputid in this case?

Thanks
pratap

4

You could do something like this:

createIds <- function(str) {
  str <- gsub("[^\\w]", "_", str, perl = TRUE)
  str <- ifelse(duplicated(str) | !nzchar(str), paste0(str, "_", seq_along(str)), str)
  str
}

That function is designed to receive a vector of names, and return names that are guaranteed to be not only safe, but also non-empty and to have no duplicates. Maybe add the result as another element from your data() reactive?

1 Like