How do you reference values of sliders in shiny? - r

Question

I need to create some sliders based on number items in a vector:
ui code:
library(shiny)
library(shinydashboard)
library(leaflet)
library(data.table)
library(ggplot2)
library(ggthemes)
library(usl)
ui<-dashboardPage(skin="green",
dashboardHeader(title = "ADM Logical Capacity Planning Service",titleWidth = 350),
dashboardSidebar(
sidebarMenu(
menuItem("Visualize & Create Model", tabName = "visualize",icon=icon("area-chart")),
menuItem("Forecast", tabName = "capacity", icon=icon("line-chart")) )
),
dashboardBody(
tags$head(tags$style(HTML('
.skin-blue .main-header .logo {
background-color: #3c8dbc;
}
.menuItem .main-header .logo:hover {
background-color: #3c8dbc;
}
'))),
tabItems(
tabItem("capacity",
fluidRow(
column(3,
wellPanel(
span("Given the growth rate, forecast the underlying dependent variable")
),
wellPanel(
# Create a uiOutput to hold the sliders
uiOutput("sliders")
),
# Generate a row with a sidebar
#sliderInput("capacity", "Growth Rate in Volume:", min=0, max=100, value=0,post="%"),
#br(),
#sliderInput("add_capacity", "Add Capacity in %:", min=0, max=100, value=0,post="%"),
br(),
wellPanel(
actionButton("calcbtn", "Calculate Forecast")
)
),
mainPanel(
h4("Prediction"),
verbatimTextOutput("forecast_summary"),
h4("Available Capacity"),
verbatimTextOutput("capacity_summary")
#h4("Peak Capacity"),
#verbatimTextOutput("peak_capacity")
)
)
),
tabItem("visualize",
pageWithSidebar(
headerPanel("Logical Capacity Planning Dashboard"),
sidebarPanel(
fileInput('file1', 'Upload CSV File to Create a Model',
accept=c('text/csv','text/comma-separated-values,text/plain','.csv')),
tags$hr(),
checkboxInput('header', 'Header', TRUE),
fluidRow(
column(6,checkboxGroupInput("xaxisGrp","X-Axis:", c("1"="1","2"="2"))),
column(6,radioButtons("yaxisGrp","Y-axis:", c("1"="1","2"="2")))
),
radioButtons('sep', 'Separator',
c(Comma=',', Semicolon=';',Tab='\t'), ','),
radioButtons('quote', 'Quote',
c(None='','Double Quote'='"','Single Quote'="'"),'"'),
uiOutput("choose_columns")
),
mainPanel(
tabsetPanel(
tabPanel("Data", tableOutput('contents')),
tabPanel("Create Model & Plot",plotOutput("plot"),verbatimTextOutput("PeakCapacity")),
tabPanel("Model Summary",verbatimTextOutput("summary"))
)
)
)
)
)
)
)
server code:
server <- function(input, output, session)
{
###
output$sliders <- renderUI({
xv <- input$xaxisGrp
# First, create a list of sliders each with a different name
sliders <- lapply(1:length(xv), function(i) {
inputName <- xv[i]
sliderInput(inputName, inputName, min=0, max=100, value=0, post="%")
})
# Create a tagList of sliders (this is important)
do.call(tagList, sliders)
})
###
observeEvent(input$calcbtn, {
n <- isolate(input$calcbtn)
if (n == 0) return()
output$forecast_summary <- renderPrint({
n<-pred.model()
n<-data.frame(n)
row.names(n)<-NULL
print(n)
})
output$capacity_summary <- renderPrint({
n<-pred.model()
n<-data.frame(n)
row.names(n)<-NULL
#c<-round(peak.scalability(usl.model()),digits=0)
available<-round(((c-n[1,1])/c)*100,digits=0)
row.names(available)<-NULL
print(paste0(available,"%"))
})
# output$peak_capacity <- renderPrint({
# print(paste("Maximum Capacity: ", round(peak.scalability(pred.model()),digits=0)))
# })
output$plot_forecast <- renderPlot({
df <- data_set()
new_df<- pred.model()
print(sliders)
if (!is.null(df)){
xv <- input$xaxisGrp
yv <- input$yaxisGrp
print(xv)
print(yv)
if (!is.null(xv) & !is.null(yv)){
if (sum(xv %in% names(df))>0){ # supress error when changing files
df1<-data.frame(usl.model()$fitted)
colnames(df1)<-c("Model")
df<-cbind(df,df1)
Model=c("Model")
#ggplot(df, aes_string(xv,yv))+geom_point(size=3,colour="blue")+geom_line(data=df, aes_string(xv,Model),colour="orange",size=1)+
#geom_point(data=new_df,aes(new_df[,1],new_df[,2]), colour="red",size=10)+theme_bw()+theme(legend.position = "none")
#max_capacity<-round(peak.scalability(usl.model()),digits=0)
Ninety_Fifth_Perc<-quantile(df[,2], 0.95)
#peak<-round(peak.scalability(usl.model()),digits=0)
#available<-round(((max_capacity-Ninety_Fifth_Perc)/max_capacity)*100,digits=0)
new_d<-pred.model()
ggplot(df, aes_string(xv,yv))+geom_point(size=4,shape=21, fill="blue")+geom_line(data=df, aes_string(xv,Model),colour="orange",size=1)+
geom_point(data=new_df,aes(new_df[,1],new_df[,2]), colour="red",size=10)+
theme_bw()+theme(legend.position = "none")+geom_vline(xintercept=new_df[,1], colour="green",size=1.5)
}
}
}
})
})
###pred function
pred.model <- reactive({
xv <- input$xaxisGrp
yv <- input$yaxisGrp
#latest_df<-do.call(data.frame,setNames(lapply(xv,function(e) vector(typeof(e))),xv))
latest_df<-data.frame()
new_df1 = data.frame()
for(i in 1:length(xv)){
##xv[i]<-as.numeric(input$xv[i])
# capacity<-as.numeric(input$capacity)
#add_capacity<-as.numeric(input$add_capacity)
df <- data_set()
if (!is.null(df)){
if (!is.null(xv) & !is.null(yv)){
if (sum(xv[i] %in% names(df))>0){ # supress error when changing files
#usl.model <- usl(as.formula(paste(yv, '~', xv)), data = df)
#new_growth<-tail(df[,xv],1)*(1+capacity/100)
new_growth<-quantile(df[,xv[i]],0.95)*(1+input$xv[i]/100)
new_cap<-new_growth
new_df1[1,i] = setNames(data.frame(new_cap),xv[i])
row.names(new_df1)<-NULL
}
}
}
}
latest_df=new_df1
prediction<-predict(usl.model(),newdata = latest_df)
prediction<-data.frame(prediction)
prediction<-prediction[1,1]
return(prediction)
})
##end of pred function
###visualize section
dsnames <- c()
data_set <- reactive({
inFile <- input$file1
data(specsdm91)
if (is.null(inFile))
return(specsdm91)
data_set<-read.csv(inFile$datapath, header=input$header,
sep=input$sep, quote=input$quote,stringsAsFactors=F)
})
output$contents <- renderTable({data_set()})
observe({
dsnames <- names(data_set())
cb_options <- list()
cb_options[ dsnames] <- dsnames
updateCheckboxGroupInput(session, "xaxisGrp",
label = "X-Axis",
choices = cb_options,
selected = "")
updateRadioButtons(session, "yaxisGrp",
label = "Y-Axis",
choices = cb_options,
selected = "")
})
output$choose_dataset <- renderUI({
selectInput("dataset", "Data set", as.list(data_sets))
})
usl.model <- reactive({
df <- data_set()
if (!is.null(df)){
xv <- input$xaxisGrp
yv <- input$yaxisGrp
print(xv)
print(yv)
if (!is.null(xv) & !is.null(yv)){
if (sum(xv %in% names(df))>0){ # supress error when changing files
xv <- paste(xv, collapse="+")
lim <- lm(as.formula(paste(yv, '~', xv)), data = df)
return(lim)
}
}
}
})
##plot
output$plot = renderPlot({
df <- data_set()
if (!is.null(df)){
xv <- input$xaxisGrp
yv <- input$yaxisGrp
print(xv)
print(yv)
if (!is.null(xv) & !is.null(yv)){
if (sum(xv %in% names(df))>0){ # supress error when changing files
#plot(as.formula(paste(yv, '~', xv)), data = df, pch = 21)
#plot(usl.model(),add=TRUE)
df1<-data.frame(usl.model()$fitted)
colnames(df1)<-c("Best_Fit_Model")
#df<-cbind(df,df1)
Model<-c("Best_Fit_Model")
df1<-cbind(df[yv],df1)
#max_capacity<-round(peak.scalability(usl.model()),digits=0)
#Ninety_Fifth_Perc<-quantile(df[,2], 0.95)
#peak<-round(peak.scalability(usl.model()),digits=0)
#available<-round(((max_capacity-Ninety_Fifth_Perc)/max_capacity)*100,digits=0)
#new_d<-pred.model()
df.melt=melt(df, id=yv)
xx<-c("value")
ggplot(df.melt,aes_string(x = xx, y = yv)) + geom_point() +facet_wrap(~variable, scale="free")+theme_bw()+
geom_smooth(method="lm", se=F, colour="red")
# p2<-ggplot(df1,aes_string(x = yv, y = Model)) + geom_point() + theme_bw()+
# geom_smooth(method="lm", se=F, colour="red")
}
}
}
} )
##
output$summary <- renderPrint({
summary(usl.model())
})
output$choose_columns <- renderUI({
if(is.null(input$dataset))
return()
colnames <- names(contents)
checkboxGroupInput("columns", "Choose columns",
choices = colnames,
selected = colnames)
})
}

Answer 1

EDIT: You're also referencing xaxisGrp as an input (which it isn't). That's causing some issues. Turns out fixing that (see the example below) makes things work nicely. I didn't realize that! Cool stuff.
Updating based on your comment, you should be able to access each input using bracket notation. Your question is still referencing input$xaxisGrp which doesn't exist, though. I'm also not sure why you're calling renderPlot({}) since nothing's being plotted.
library(shiny)
ui <- shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("sliders")
),
mainPanel(
)
))
server <- shinyServer(function(input, output, session) {
xaxisGrp <- c("CPU", "Memory", "Disk")
output$sliders <- renderUI({
xv <- xaxisGrp
sliders <- lapply(1:length(xv), function(i) {
inputName <- xv[i]
sliderInput(inputName, inputName, min=0, max=100, value=0, post="%")
})
do.call(tagList, sliders)
})
output$plot_forecast <- renderPlot({
xv <- xaxisGrp
for(i in 1:length(xv)) {
value <- input[xv[i]]
}
})
})
I'm a little unsure why you're constructing the sliders this way. Have you looked into namespacing? Or even just write 3 separate outputs? For example (you can run this to see each input <key, value> pair):
library(shiny)
ui <- shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
uiOutput("slider1"),
uiOutput("slider2"),
uiOutput("slider3"),
uiOutput("sliders")
),
mainPanel(
verbatimTextOutput("inputVals")
)
)
))
server <- shinyServer(function(input, output, session) {
output$slider1 <- renderUI({
sliderInput("CPU2", "CPU2", min=0, max=100, value=0, post="%")
})
output$slider2 <- renderUI({
sliderInput("Memory2", "Memory2", min=0, max=100, value=0, post="%")
})
output$slider3 <- renderUI({
sliderInput("Disk2", "Disk2", min=0, max=100, value=0, post="%")
})
output$sliders <- renderUI({
xv <- c("CPU","Memory","Disk")
sliders <- lapply(1:length(xv), function(i) {
inputName <- xv[i]
sliderInput(inputName, inputName, min=0, max=100, value=0, post="%")
})
do.call(tagList, sliders)
})
output$inputVals <- renderPrint({
print(reactiveValuesToList(input))
})
})
# Run the application
shinyApp(ui = ui, server = server)
In your case, it looks like your inputs are all rendering without any ID (xaxisGrp isn't a valid input in your example). That's bad, they each need a unique one. Namespacing is one way to solve for this by abstracting the UI-generating functions and guarantee unique IDs for each input. Less cumbersome most times (unless, I don't know, you need to dynamically generate them based on some external factor) is to just create multiple individual inputs.
Once you're building the inputs correctly, then to access any given input's value, just use the input$inputId syntax within any reactive context:
output$CPUValue <- renderText({
input$CPU
})