I am trying to build a shiny app that gives new predictions based on various user inputs.
However, even though the input values are updating with the inputs, the prediction value does not update. Im am having trouble figuring out why.
The model is a random forest regression model, in the example I am using numeric variables but in my situation the inputs are categorical (I dont think this change should effect anything) This is why the sidebar is all select input as opposed to select numeric
I made a reproducible example with the mtcars dataset
model <- ranger(mpg ~ disp + hp + wt, data = mtcars)
ui <- fluidPage(
sidebarPanel(
selectInput('disp', 'disp',
choices = unique(mtcars$disp),
selected = unique(mtcars$disp)[1]),
selectInput('hp', 'hp',
choices = unique(mtcars$hp),
selected = unique(mtcars$hp)[1]),
selectInput('wt', 'wt',
choices = unique(mtcars$wt)),
actionButton("Enter", "Enter Values"),
width = 2
),
mainPanel(
tableOutput('mpg')
)
)
server <- function(input, output, session) {
val <- reactive({
new <- mtcars[1, ]
new$disp <- input$disp
new$hp <- input$hp
new$wt <- input$wt
new
})
out <- eventReactive(
input$Enter,
{
val <- val()
val$pred <- predict(model, data = val)$predictions
val
})
output$mpg <- renderTable({
out()
})
}
shinyApp(ui, server)
There are several issues here.
1) You are using selectInput incorrectly. See below. Basically, using indexes like mtcars$disp[1] will create static values, no matter what is selected.
2) You are using renderTable() when you are only producing a single value as output. Why not just use renderText()? See below.
3) The eventReactive trigger (i.e., input$enter) needs to be used to create the data frame of input values. The model prediction can run on the data frame later, but the initial trigger actually pulls the values from selectInput, so the trigger needs to be in the same block where the data frame is created.
This ran correctly and produced the desired output on my machine:
library(shiny)
library(ranger)
model <- ranger(mpg ~ disp + hp + wt, data = mtcars)
ui <- fluidPage(
sidebarPanel(
selectInput('disp', 'disp',
unique(mtcars$disp)),
selectInput('hp', 'hp',
unique(mtcars$hp)),
selectInput('wt', 'wt',
unique(mtcars$wt)),
actionButton("enter", label = "Enter Values"),
width = 2
),
mainPanel(
textOutput('mpg')
)
)
server <- function(input, output, session) {
val <- eventReactive(
input$enter, {
data.frame(
disp = input$disp,
hp = input$hp,
wt = input$wt,
stringsAsFactors = F
)}
)
output$mpg <- renderText({
predict(model, val())[[1]]
})
}
shinyApp(ui, server)
Related
There are several questions on this issue, including here, but I am still not sure what I need to change to get this right.
The selectInput choices are working as expected, other than when I change the second selectInput, it temporarily changes to the desired selection but then automatically goes back to the first filtered selection.
For example, if "gear" is chosen for Variable 1, then the Variable 1 choices correctly display "3, 4, 5" for possible gear choices. If I select "5" for gear, it briefly shows up and then goes back to gear "3" as a choice. I am not sure how to prevent that reactive behavior.
Here is a simple reproducible example using the mtcars built-in data set:
library(tidyverse)
library(shiny)
# Variables interested in selecting
my_vars <- c("cyl", "gear", "carb")
# UI
ui <- fluidPage(
# Title
titlePanel("Reprex"),
# Sidebar
sidebarLayout(
sidebarPanel(
selectInput("sel_1",
"Variable 1",
choices = my_vars,
selected = my_vars[[1]],
multiple = FALSE
),
selectInput("sel_2",
"Variable 1 choices",
choices = unique(mtcars[[ my_vars[[1]] ]]),
multiple = FALSE
)
), # sidebarPanel close
# Plot
mainPanel(
plotOutput("plot_out")
) # mainPanel close
) # sidebarLayout close
) # UI close
# Server
server <- function(input, output, session) {
output$plot_out <- renderPlot({
# Assign inputs
sel_1 <- input$sel_1
sel_2 <- input$sel_2
# Make drop-down choice of sel_2 dependent upon user input of sel_1
# *** Must put "shiny::observe" instead of "observe" since "observe" is masked by the Tidy infer package ***
shiny::observe({
updateSelectInput(session,
"sel_2",
choices = sort(unique(mtcars[[sel_1]]))
)
})
# Data to plot
my_data <- mtcars %>%
filter(.data[[sel_1]] == sel_2)
# Plot
p <- ggplot(my_data, aes(x = factor(.data[[sel_1]]), y = hp)) + geom_point()
p
})
}
# Run the application
shinyApp(ui = ui, server = server)
That's because your observer is inside the renderPlot. It has nothing to do here.
server <- function(input, output, session) {
# Make drop-down choice of sel_2 dependent upon user input of sel_1
observeEvent(input$sel_1, {
updateSelectInput(session,
"sel_2",
choices = sort(unique(mtcars[[input$sel_1]]))
)
})
output$plot_out <- renderPlot({
# Assign inputs
sel_1 <- input$sel_1
sel_2 <- input$sel_2
# Data to plot
my_data <- mtcars %>%
filter(.data[[sel_1]] == sel_2)
# Plot
ggplot(my_data, aes(x = factor(.data[[sel_1]]), y = hp)) + geom_point()
})
}
Here the observeEvent instead of observe is not necessary, since input$sel_1 is the only reactive value inside the observer, but I find that observeEvent is more readable.
Also, avoid to load tidyverse. That loads a ton of packages you don't need. Here dplyr and ggplot2 are enough
I have a huge shiny app and met with the below issue. I tried to provide pseudo code for the problem since it is nearly impossible for my expertize to creating working app to demonstrate the problem. I hope i have conveyed with the pseudo code. Kindly help me.
Here is the pseudo code in ui.R file which has an actionButton and a radioButton with underlying selectizeInput and checkboxGroupInput input options and plotOutput to render a plot.
###ui.R#####
tabPanel("Plots",
fluidRow(column(4,wellPanel(
actionButton("action_plot","Generate Plots"),
h6(textOutput("numheat")),
radioButtons("plot_subset",label="Chose by sample or group?",
choices=c("Sample","Group"),selected="Sample"),
conditionalPanel("input.plot_subset=='Sample'",
selectizeInput("view_sample_plot",
label = h5("Select Samples"),
choices = NULL,
multiple = TRUE,
options = list(placeholder = 'select samples to plot')
)
),
conditionalPanel("input.plot_subset=='Group'",
checkboxGroupInput("view_group_plot",
label=h5("Select Groups to View"),
choices="",
selected="")
)
)
),
column(8,
tabsetPanel(
tabPanel(title="Plot",
#textOutput("which_genes"),
h4(textOutput("plot_title")),
plotOutput("plot_rna",height="800px")
)
)
)
)
)
Below is the pseudo server.R code that observes the user input values and updates updateSelectizeInput and updateCheckboxGroupInput with choice from the default loaded R dataset. The user selected choices are used in the subsequent function to generate plot.
###server.R#####
## observed the user input and updated the selectize input and checkBoxGroup input values#####
observe({
print("server-plot-update")
# browser()
data_analyzed = inputData()
tmpgroups = data_analyzed$group_names
tmpdatlong = data_analyzed$data_long
tmpsamples = unique(tmpdatlong$sampleid)
tmpynames = tmpdatlong$
updateSelectizeInput(session,'view_sample_plot',
choices=tmpsamples, selected=NULL)
updateCheckboxGroupInput(session,'view_group_plot',
choices=tmpgroups, selected=NULL)
})
#####code to render plot based on user selection value i.e. by group or samples######
##plot_render utilizes the R functions in Plot.R file to subset the data by user input and generate plot###
plotdatReactive <- reactive({
data_analyzed = inputData
tmp <- plot_data(data_analyzed = data_analyzed,
yname="log2",
orderby="significance",
view_group=input$view_group_plot,
view_sample=input$view_sample_plot)
tmp
})
output$plot_rna <- renderPlot({
if(input$action_plot==0) return()
isolate({
tmp = plotdatReactive()
plot_render( data_analyzed=tmp,
yname = input$heatmapvaluename,
view_group=input$view_group_plot,
view_sample=input$view_sample_plot
)
})
})
Pseudo Code for R functions in plot.R file
####plot.R#####
###function to subset data based on user input samples or groups###
plot_subdat <- function(data_analyzed,
yname="log2",
orderby="significance",
view_sample=NULL,
view_group=NULL) {
if(is.null(view_sample)) view_sample=unique(data_analyzed$sampleid) ## sample names in the dataset
if(is.null(view_group)) view_group=data_analyzed$group_names ## group names in the dataset
tmpdat = data_analyzed$data_long
##subset dataset by **sampleid** if the user selected **samples** in SelectizeInput
tmpdat = tmpdat%>%filter(sampleid%in%view_sample)
subdat = filter(data_analyzed$data_long,unique_id%in%thesegenes,sampleid%in%view_sample)
#subset dataset by **group** if the user selected **group** in checkBoxGroup input
tmpdat = tmpdat%>%filter(group%in%view_group)
subdat = filter(data_analyzed$data_long,unique_id%in%thesegenes,group%in%view_group)
}
###this function generates the plot on the subset of data from the above function#####
plot_data <- function(...) {
tmpdat = plot_subdat(...)
plotdat = tmpdat$data
plotdat
}
The tmpdat and subdat are the inputs to generate the plot in plot_render function. If the user selects and inputs values through selectizeInput then the subsetting of data should be done by samples. If the user selects and input through checkBoxGroupInput then the subsetting should be done by group as commented in the code. I am not unable to subset the data based on user selection i.e. sample/group reactively in plot_subdat function. How can i do this reactively so that the output plot is generated as per the user selection.
I think you might want a reactive expression to subset your data.
Here is a basic working example that includes your inputs, and will plot subsetted data based on input selections reactively.
Edit:
The filtering of data is now in an external .R file, with input variables to filter on passed through.
library(shiny)
source("plot.R", local = TRUE)
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Plots",
fluidRow(column(4,wellPanel(
#actionButton("action_plot","Generate Plots"),
h6(textOutput("numheat")),
radioButtons("plot_subset",label="Chose by sample or group?",
choices=c("Sample","Group"),selected="Sample"),
conditionalPanel("input.plot_subset=='Sample'",
selectizeInput("view_sample_plot",
label = h5("Select Samples"),
choices = NULL,
multiple = TRUE,
options = list(placeholder = 'select samples to plot')
)
),
conditionalPanel("input.plot_subset=='Group'",
checkboxGroupInput("view_group_plot",
label=h5("Select Groups to View"),
choices="",
selected="")
)
)),
column(8,
tabsetPanel(
tabPanel(title="Plot",
#textOutput("which_genes"),
h4(textOutput("plot_title")),
plotOutput("plot_rna",height="800px")
)
)
)
)
)
)
)
)
server <- function(input, output, session) {
observe({
updateSelectizeInput(session,'view_sample_plot',
choices=unique(mtcars$gear), selected=NULL)
updateCheckboxGroupInput(session,'view_group_plot',
choices=unique(mtcars$cyl), selected=NULL)
})
plot_prepare <- reactive({
if (input$plot_subset == "Sample") {
plot_subdat(mtcars, "gear", input$view_sample_plot)
} else {
plot_subdat(mtcars, "cyl", input$view_group_plot)
}
})
output$plot_rna <- renderPlot({
plot(plot_prepare())
})
}
shinyApp(ui, server)
plot.R
# plot.R file
library(tidyverse)
plot_subdat <- function(data, variable, choices) {
data %>%
filter((!!sym(variable)) %in% choices) %>%
select(c(!!sym(variable), mpg))
}
Reformulating my question, I´m trying to synthetize a data frame reactively, with a selectinput = c("col_1","col_2","col_3","col_4","col_5")
My dataframe looks something like this
Date . Store_ID . Sales . Stock . ETC
I need to be able to sum all the data in the same stores, with the different user selected columns.
Using the mtcars dataframe as an example to work with, my objective is to have a table like this
SelectInput = disp
cyl - disp
4 - sum(every 4 cylinders disp)
6 - sum(every 6 cylinders disp)
8 - sum(every 8 cylinders disp)
SelectInput = qsec
cyl . qsec
4 . sum(every 4 cylinders qsec)
6 . sum(every 6 cylinders qsec)
8 . sum(every 8 cylinders qsec)
library(shiny)
library(tidyverse)
ui <- bootstrapPage(
selectInput(
"col",
"Column",
colnames(mtcars),
selected = "mpg"),
plotOutput("histCentile", height = 200)
)
server <- function(input, output) {
data <- reactive({
mtcars() %>%
group_by(cyl = cyl) %>%
pull(input$col) %>%
sum()
})
output$histCentile <- renderPlot({
hist(data()$[[input$col]],
main = "Graph",
xlab = "Units",
xlim = range(data()$[[input$col]]),
col = '#00DD00',
border = 'white')
})
}
# Run the application
shinyApp(ui = ui, server = server)
I'm not sure what you're trying to do but here is a minimal reproducible example using reactive to filter data based on the selectInput variable.
library(shiny)
library(tidyverse)
ui <- bootstrapPage(
selectInput(
"col",
"Column",
colnames(mtcars),
selected = "mpg"),
textOutput("selected_col")
)
server <- function(input, output) {
data <- reactive({
mtcars %>% pull(input$col) %>% sum()
})
output$selected_col <- renderText({
sprintf("The sum of column %s is %f", input$col, data())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Explanation: In data we sum the values from input$col based on the selectInput selection. data is therefore a reactive value, which we show in output$selected_col.
Update
There are a few issues with your updated code example:
In the reactive block, you're summarising data to give a single number. Plotting a histogram based on a single number makes no sense. Secondly, there is a typo: it should be mtcars not mtcars(); and lastly, group_by(cyl = cyl) is unnecessary as you don't do any group-wise calculation afterwards (it should also be group_by(cyl)).
You don't actually need a reactive block here at all, since you can do the filtering in renderPlot directly but I guess that is a matter of personal preference.
The following dynamically updates a histogram based on the selected column from selectInput
library(shiny)
library(tidyverse)
ui <- bootstrapPage(
selectInput(
"col",
"Column",
colnames(mtcars),
selected = "mpg"),
plotOutput("histo")
)
server <- function(input, output) {
data <- reactive({
mtcars %>% pull(input$col)
})
output$histo <- renderPlot({
hist(data())
})
}
# Run the application
shinyApp(ui = ui, server = server)
Update - Solution
Thanks to Maurits Evers help, and some research, I managed to do what I wanted to
library(shiny)
library(tidyverse)
ui <- bootstrapPage(
selectInput(
"col",
"Column",
colnames(mtcars),
selected = "mpg"),
plotOutput("histo")
)
server <- function(input, output) {
data <- reactive({
Graphby <- input$col
with(mtcars,aggregate(qsec,list(cyl=cyl),sum))
aggregate(mtcars[[Graphby]],list(cyl=mtcars$cyl),sum)
})
output$histo <- renderPlot({
hist(data()$x)
})
}
# Run the application
shinyApp(ui = ui, server = server)
What it does is an interactive histogram by merging groups of data like this
in a reactive way, by choosing different columns.
Issue:
I have a data frame where row A is the names of people in my organization. I have a separate data frame that is a subset of row A in the original table. I would like to highlight all rows in the first data table that match names in the second table. Essentially, I have two sets. Set A and Set B. Both are names, I would like to highlight the data table for all names in Set A that match Set B. However, I keep getting an error: length(levels) must be equal to length(values)
How would I avoid receiving this error?
Reproducible Example:
I have a data frame of mtcars. I am filtering the mtcars dataset based on a slider input for mpg. I would like to highlight the data frame of mtcars that meet the filtering criteria. In effect, this would mean highlighting the output table for all observations where the mpg are <= the slider input mpg.
library(shiny)
# Define UI for application that draws a histogram
ui <- fluidPage(
# Application title
titlePanel("Highlight Cell Test (Sets)"),
sidebarLayout(
sidebarPanel = 'side',
sliderInput('slider', 'slider input', 1, 30, 20)),
# Show a plot of the generated distribution
mainPanel(
dataTableOutput("test")
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
subset <- reactive({
mtcars %>%
filter(mpg <= input$slider)
})
output$test <- DT::renderDataTable(
mtcars %>%
DT::datatable(
options = list(
dom = 'ftipr',
searching = TRUE
) %>%
formatStyle(
'test',
background = styleEqual(
(subset()$mpg %in% mtcars$mpg), 'lightgreen'))
)
)
}
# Run the application
shinyApp(ui = ui, server = server)
Any help is much appreciated. Thanks in advance.
You can do this via rowCallback like so:
library(shiny)
library(dplyr)
library(DT)
fnc <- JS('function(row, data, index, rowId) {','console.log(rowId)','if(rowId >= ONE && rowId < TWO) {','row.style.backgroundColor = "lightgreen";','}','}')
ui <- fluidPage(
# Application title
titlePanel("Highlight Cell Test (Sets)"),
sidebarLayout(
sidebarPanel = 'side',
sliderInput('slider', 'slider input', 1, 30, 16)),
# Show a plot of the generated distribution
mainPanel(
dataTableOutput("test")
)
)
# Define server logic required to draw a histogram
server <- function(input, output, session) {
subset <- reactive({
mtcars %>% filter(mpg <= input$slider)
})
Coloring <- eventReactive(subset(),{
a <- which(subset()$mpg %in% mtcars$mpg)
print(a)
if(length(a) <= 0){
return()
}
fnc <- sub("ONE",a[1],fnc)
fnc <- sub("TWO",max(a),fnc)
fnc
})
output$test <- DT::renderDataTable(
mtcars %>%
DT::datatable(options = list(dom = 'ftipr',searching = TRUE,pageLength = 20, scrollY = "400px",rowCallback = Coloring()))
)
}
shinyApp(ui = ui, server = server)
I have a problem. I want to use sidebar to curb time series plot, however, I get invalid formula error when trying to do the plot. Can someone pls help?
server.r
library(shiny)
library(BCA)
data(Eggs)
# Define server logic required to plot
shinyServer(function(input, output) {
formulaX <- reactive({
tmp <- paste(input$range,collapse = ":")
paste("Eggs[",tmp,",1]")
})
formulaY <- reactive({
tmp1 <- paste(input$range,collapse = ":")
paste("Eggs[",tmp1,",5]")
})
# Return the formula text for printing as a caption
output$caption <- renderText({
paste(formulaX(),formulaY(),sep = " ")
})
#creating plot -ERROR
output$mpgPlot <- renderPlot({
plot(as.formula(formulaX()),as.formula(formulaY()))
})
})
ui.r
library(shiny)
# Define UI
shinyUI(pageWithSidebar(
# Application title
headerPanel("Eggs"),
sidebarPanel(
# Specification of range within an interval
sliderInput("range", "Range:",
min = 1, max = 105, value = c(20,50))
),
mainPanel(
h3(textOutput("caption")),
plotOutput("mpgPlot")
)
))
"Eggs[1:10,1]" is not a formula, it is a character-representation of a subset. Since you are always choosing columns 1 and 5, your "formula" is always "Cases ~ Week" (I don't have BCA installed, I think that's correct), and you are intending to use a subset of rows from the data.
Perhaps this would work instead (hasty, some programming safeguards would be appropriate):
# no need for formulaX(), formulaY()
# not certain what you want/need from output$caption
dataX <- reactive({ Eggs[input$range[1]:input$range[2],,drop = FALSE] })
and your plot:
output$mpgPlot <- renderPlot({
plot(Cases ~ Week, data = dataX())
})
or
output$mpgPlot <- renderPlot({
x <- dataX()
plot(x$Week, x$Cases)
})