Preventing Shiny selectInput from evaluating prematurely when updating a reactive plot - r

I am working on a Shiny app that generates various plots and allows users to change graphing parameters. For this, I'm using a combination of selectInput, numericInput, and checkboxInput functions after the plot is generated (conditionalPanel). I packaged the code so that the data.frame used for the graph is calculated reactively (to allow flexible subsetting before plotting). Everything works great, but when I want to update some graphing parameters (such as colors to use via selectInput), the code breaks down because it evaluates prematurely before I select all the necessary colors (i.e. when there are 4 colors needed, code breaks right after selecting the first color).
I know about debounce function to delay evaluation, but I don't want to use it because:
I like the instant changes in the graph when I update other parameters
Selection of colors can take some time, so it is difficult to set a predetermined delay time/time interval
One solution can be to add an actionButton shown conditionally (along with other graphing parameters) to regulate the firing of the reactive input values (see below). This is not ideal because after changing parameters, I need to click on update to renew the graph. Also, I'm not sure how this would even work because the km_graph is already a reactive plot object. Alternatively, is there a solution for regulating selectInput specifically so that until all the colors selected, it is not evaluated?
I read several posts on this issue but I couldn't find a solution that works with the design of my code. I will try to write sections of my ui and server to give an idea of what I'm trying to do:
ui.R
# ...
mainPanel(
plotOutput("km_graph"),
# Conditional panel prompted only after the km_graph is generated
conditionalPanel(
condition = "output.km_graph" ,
checkboxInput("km_risk", label="Show risk table", F),
selectInput("km_medline", label = "Mark median survival",
selected = "hv",
choices = c("None" = "none",
"Horizontal-Vertical" = "hv",
"Vertical" = "v",
"Horizontal" = "h")),
sliderInput("km_xlim", label="days", value = 6000, min = 10, max=10000),
selectInput("km_pal", "Select colors", multiple = T,
selectize = T,
selected = "jco",
choices = list(`Pre-made palettes` = list("npg","aaas", "lancet", "jco",
"ucscgb", "UChicago",
"simpsons", "rickandmorty")
`Individual colors` = as.list(color_choices))
)
# Need to find a way to prevent evaluating before all the colors are selected for km_pal
# Maybe another actionButton() here to update graph after all the parameters are selected?
server.R
#...
# km_results() is the reactive object containing survival analysis results
# km_dat() is the reactive data frame used in the analyses
output$km_graph <- renderPlot({
survminer::ggsurvplot(km_results(), data = km_dat(),
pval = input$km_pval,
pval.method = input$km_pval,
risk.table = input$km_risk,
conf.int = input$km_confint,
surv.median.line = input$km_medline,
break.time.by = input$km_breaktime,
legend="right",
xlim=c(0, input$km_xlim),
palette = input$km_pal) ###### This breaks due to premature evaluation
})
Full Reprex
shinyApp(
ui = basicPage(
selectInput("dat", "Select data",
selected = "iris", choices = c("iris")),
actionButton("go", "Go!"),
plotOutput("plot"),
conditionalPanel(
h3("graphing options"),
condition = "output.plot",
checkboxInput("plot_point", "Show points", T),
selectizeInput("plot_colors", "Select colors", selected="jco",
choices = list(`premade`=list("jco", "npg"),
`manual`=list("red", "black", "blue")))
)
),
server = function(input, output) {
dat <- reactive({
if(input$dat == "iris") iris
})
output$plot <- renderPlot({
req(input$go)
ggpubr::ggscatter(dat(), "Sepal.Length", "Sepal.Width",
color="Species", palette=input$plot_colors)
})
}
)
Thanks for the insights!

I'm not 100% sure I fully understood, but you could for example pass the plot_colors input in a reactive variable that is triggered by an action button "Apply colors" ?
(you need to add multiple = TRUE in the selectizeInput's arguments)
Here is an example of code based on your reprex:
shinyApp(
ui = basicPage(
selectInput("dat", "Select data",
selected = "iris", choices = c("iris")),
actionButton("go", "Go!"),
plotOutput("plot"),
conditionalPanel(
h3("graphing options"),
condition = "output.plot",
checkboxInput("plot_point", "Show points", T),
selectizeInput("plot_colors",
"Select colors",
selected="jco",
multiple = TRUE,
choices = list(`premade`=list("jco", "npg"),
`manual`=list("red", "black", "blue"))),
actionButton(inputId = "apply", label = "Apply colors")
)
),
server = function(input, output) {
dat <- reactive({
if(input$dat == "iris") iris
})
params_curve <- shiny::eventReactive(eventExpr = input$apply,
{
return(list(colors = input$plot_colors))
},
ignoreNULL = F,
ignoreInit = F
)
output$plot <- renderPlot({
req(input$go)
ggpubr::ggscatter(dat(), "Sepal.Length", "Sepal.Width",
color="Species", palette=params_curve()$colors)
})
}
)
If you select "red", "black", and "blue", then the dimension of your plot_colors variable is 3. So, the plot is rendered.

Related

Get "selected data" in a parallel coordinates chart using plotly to update table

As couple of users before, I want to update a table conditional on the selected lines in a parallel coordinates chart produced by plotly in R. I found a similar question for Python but don't get it working in R.
Though I get the latest dynamic interaction/selection by event_data("plotly_restyle"), I have the following issues:
It provides only information for the axis the user has changed the latest and no information about all other axes which are returned as NULL. Though this is annoying, it can be resolved by updating e.g. a reactive value in the background observing the "event data" (not shown).
Unselecting the selection area by a double click, gives back a NULL which has to be used for resetting the selection.
In case the user modifies the order of the axis per manually dragging the axis, I get a different output and actually which lists a perfect summary of the order of all axes/variables and their user defined limits. This is actually the output I want to get in any case, so also when just a single axis is updated.
I give a minimal example to play with and to better understand my given points above (based on a official plotly example). Any input welcome!
library("shiny")
library("plotly")
library("DT")
ui <- fluidPage(
headerPanel("Example"),
mainPanel(
plotlyOutput("plot"),
verbatimTextOutput("text"),
DTOutput("table")
)
)
server <- function(input, output, session) {
df <- reactive({read.csv("https://raw.githubusercontent.com/bcdunbar/datasets/master/iris.csv")})
output$plot <- renderPlotly({
fig <- plot_ly(
data = df(),
source = "myplot",
type = "parcoords",
line = list(color = ~species_id,
colorscale = list(c(0, "red"), c(0.5, "green"), c(1, "blue"))),
dimensions = list(
list(
range = c(2,4.5),
label = "Sepal Width",
values = ~sepal_width
),
list(
range = c(4,8),
constraintrange = c(5,6),
label = "Sepal Length",
values = ~sepal_length
),
list(
range = c(0,2.5),
label = "Petal Width",
values = ~petal_width
),
list(range = c(1,7),
label = "Petal Length",
values = ~petal_length
)
)
)
fig
fig <- event_register(fig, "plotly_restyle")
})
output$text <- renderPrint({
event_data("plotly_restyle", source = "myplot", session = session)
})
output$table <- renderDT({
datatable(
df()
)
})
}
shinyApp(ui,server)

How to grey out traces not selected in a parallel coordinate plot using the ‘parcoords’ package in R Shiny?

I am using the R library ‘parcoords’ to create an interactive parallel coordinates plot. By default, when no selection along any axis is made, the plot shows all traces. When some range is selected across an axis only the traces within the selection window are visible and all other traces disappear. I was wondering if there is a way for the other traces to be just greyed out but still visible on the plot similarly to the parallel coordinate plot using the plotly package?
Thank you!
library(shiny)
library(parcoords)
library(d3r)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
),
mainPanel(
parcoordsOutput("par_plot")
)
)
)
server <- function(input, output) {
output$par_plot<- renderParcoords({
data(mtcars)
parcoords(mtcars, rownames = TRUE, brushMode = "1d-axes-multy", reorderable = FALSE,
color = list(
colorBy = "mpg",
colorScale = "scaleOrdinal",
colorScheme = "schemeCategory10"
),
withD3 = TRUE)
})
}
shinyApp(ui = ui, server = server)
I have managed to figure out something very similar which also works for me i.e. instead of grey out the traces that are not selected, make them more transparent so that they don't stand out compared to the selected ones. This is achieved by using the parcoords parameter 'alphaOnBrushed'. I set it to 0.15 and the plot looks exactly the way I want it in terms of emphasising the brushed traces.
library(shiny)
library(parcoords)
library(d3r)
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
),
mainPanel(
parcoordsOutput("par_plot")
)
)
)
server <- function(input, output) {
output$par_plot<- renderParcoords({
data(mtcars)
parcoords(mtcars, rownames = TRUE, brushMode = "1d-axes-multy", reorderable = FALSE,
alphaOnBrushed = 0.15,
color = list(
colorBy = "mpg",
colorScale = "scaleOrdinal",
colorScheme = "schemeCategory10"
),
withD3 = TRUE)
})
}
shinyApp(ui = ui, server = server)

Removing UI drop-down element dynamically in R Shiny

Probably very basic question - but can't translate similar posts I've found to my exact issue.
Within an R Shiny app, I have a first drop-down menu that is populated by a vector produced on the server - this allows me to make one set of choices.
I want to have a tick box that then introduces a second drop down - but I want that drop down to disappear if I un-tick the tick box.
I've had a go - see MWE below - the graph is just there to keep to the structure of my original code (obviously I'm aware my drop-downs do nothing but that's not the case in the original but wanted the MWE to be as 'M' as possible).
If I remove the removeUI() line then ticking the tick-box does create a new drop down as required - but then un-ticking the tick box fails to remove it.
I'm obviously missing something; any help much appreciated as I totally suck at R Shiny but really want to get better!
library(shiny)
library(shinyMobile)
# define UI elements
ui <- f7Page(
f7SingleLayout(
navbar = f7Navbar(
),
f7Card(htmlOutput("initial_drop_down"), #first drop down
f7checkBox(inputId = "switch", label = "Introduce second choice", FALSE), #tick box for second drop down if required
htmlOutput("reactive_drop_down") #second drop down
),
f7Shadow(
intensity = 16,
f7Card(
plotOutput("distPlot", height = "800px") # plot - originally linked to drop down choices but an arbitrary graph here for simplicity
)
)
)
)
# server calculations
server <- function(input, output) {
library(ggplot2)
# generate first drop down - done on server side since usually choices vector is comprised of information read in from files
output$initial_drop_down = renderUI({
selectInput(inputId = "initial_choice",
label = "First choice:",
choices = c("Choice 1", "Choice 2", "Choice 3"))
})
observeEvent(input$initial_choice, {
# trying to add second drop down based on action in switch - not convinced my use of observeEvent is quite right - issue likely sits in here.
observeEvent(input$switch, {
if(input$switch == T){
output$reactive_drop_down = renderUI({
selectInput(inputId = "second_choice",
label = "Second (dynamic) choice:",
choices = c(1,2,3))
})
}else{
removeUI(selector ="#reactive_drop_down")
}
})
output$distPlot <- renderPlot({
ggplot(data = cars) + geom_line(aes(x=speed, y=dist))
})
})
}
# Run the application
shinyApp(ui = ui, server = server)
Could you use conditionalPanel? Put your htmlOutput for your second input there in your ui. I would avoid using nested observeEvent and output.
library(shiny)
library(shinyMobile)
library(ggplot2)
# define UI elements
ui <- f7Page(
f7SingleLayout(
navbar = f7Navbar(
),
f7Card(htmlOutput("initial_drop_down"), #first drop down
f7checkBox(inputId = "switch", label = "Introduce second choice", FALSE), #tick box for second drop down if required
conditionalPanel(
condition = "input.switch==1",
htmlOutput("reactive_drop_down") #second drop down
)
),
f7Shadow(
intensity = 16,
f7Card(
plotOutput("distPlot", height = "800px") # plot - originally linked to drop down choices but an arbitrary graph here for simplicity
)
)
)
)
# server calculations
server <- function(input, output) {
# generate first drop down - done on server side since usually choices vector is comprised of information read in from files
output$initial_drop_down = renderUI({
selectInput(inputId = "initial_choice",
label = "First choice:",
choices = c("Choice 1", "Choice 2", "Choice 3"))
})
output$reactive_drop_down = renderUI({
selectInput(inputId = "second_choice",
label = "Second (dynamic) choice:",
choices = c(1,2,3))
})
output$distPlot <- renderPlot({
ggplot(data = cars) + geom_line(aes(x=speed, y=dist))
})
}
# Run the application
shinyApp(ui = ui, server = server)

Why does my app work locally, but not on shinyapps.io?

I'm trying to deploye my shiny app on shinyapps.io and I get this message :
"An error has occurred
The application failed to start (exited with code 1)."
I tried to commit setwd line and other stuff but yet I didn't find solution.
The issue might be a wrong file path ? Should I put the "read.csv" line into my server or ui function ?
Here is my code :
#setwd(dir = "/media/miles/MILES/Projets & Cours/Master_1/Semestre 2/lardjane/Shiny_app/Projet Shiny")
matches <- read.csv('./matches.csv', stringsAsFactors=FALSE, sep=",", header=TRUE)
matches <- matches[,c(3,6)]
#summary(matches)
matches$platformid <- as.factor(matches$platformid)
#levels(matches$platformid)
#install.packages('shiny')
library(shiny)
#install.packages('rsconnect')
library(rsconnect)
ui <- shinyUI(fluidPage(
# Give the page a title
titlePanel("Game time by server"),
# Generate a row with a sidebar
sidebarLayout(
# Define the sidebar with one input
sidebarPanel(
selectInput("region", "Server:",
choices=levels(matches$platformid)),
hr(),
selectInput(inputId = "n_breaks",
label = "Number of bins in histogram (approximate):",
choices = c(10, 20, 35, 50),
selected = 20),
hr(),
checkboxInput(inputId = "individual_obs",
label = strong("Show individual observations"),
value = FALSE),
checkboxInput(inputId = "density",
label = strong("Show density estimate"),
value = FALSE),
conditionalPanel(condition = "input.density == true",
sliderInput(inputId = "bw_adjust",
label = "Bandwidth adjustment:",
min = 0.2, max = 2, value = 1, step = 0.2)),
hr(),
helpText("Data from Kaggle (2014-2018) League of Legends Ranked Matches.")
),
# Create a spot for the barplot
mainPanel(
plotOutput("timePlot")
)
)
)
)
server <- function(input, output) {
# Fill in the spot we created for a plot
output$timePlot <- renderPlot({
# Render a histogramme
hist(matches[matches$platformid==input$region,2],
probability = TRUE,
breaks = as.numeric(input$n_breaks),
main = "Game Time",
ylab="",
xlab="Duration (seconds)")
if (input$individual_obs) {
rug(matches[matches$platformid==input$region,2])
}
if (input$density) {
dens <- density(matches[matches$platformid==input$region,2],
adjust = input$bw_adjust)
lines(dens, col = "blue")
}
})
}
shinyApp(ui = ui, server = server)
I would like to add one last request. I would like to display R code just below the plot. That can anyone can get access to both (app result and R code). Is that possible ?
Thank you in advance.
swd is not the way to solve this because of how the environments in Shiny (and R in general) work. When you launch Shiny you actually don't know what physical server your Shiny server is running on. So you need to use a generic solution.
Try this:
matches <- read.csv('./matches.csv',
stringsAsFactors=FALSE, sep=",", header=TRUE)
Per https://docs.rstudio.com/shinyapps.io/Storage.html, if the csv file is in the same location as the app, try :
matches <- read.csv('matches.csv', stringsAsFactors=FALSE, sep=",", header=TRUE)
However, I don't think this is your issue; I think the issue is in your rendering of the plot. You use the input$region to generate your histogram, but you don't provide a default value, so it starts as NULL, which causes an issue when you try to construct your histogram. You have 2 options to solve this.
Option 1 is to set a default value for input$region with:
selectInput("region", "Server:",
choices=levels(matches$platformid),
selected = levels(matches$platformid)[1]),
Option 2 is to use req() so that the histogram will not run if any of its required values are not truthy:
server <- function(input, output) {
# Fill in the spot we created for a plot
output$timePlot <- renderPlot({
req(input$region, input$n_breaks)
# Render a histogramme
hist(matches[matches$platformid==input$region,2],
probability = TRUE,
breaks = as.numeric(input$n_breaks),
main = "Game Time",
ylab="",
xlab="Duration (seconds)")
if (input$individual_obs) {
rug(matches[matches$platformid==input$region,2])
}
if (input$density) {
dens <- density(matches[matches$platformid==input$region,2],
adjust = input$bw_adjust)
lines(dens, col = "blue")
}
})
}

Conditional Main Panel in Shiny

I'm building a Shiny App where I want the Main Panel to be dynamic, such that when one drop down menu is chosen a new plot is created. I understand how to do it where the plots are on top of each other (which sucks because I have table underneath that and the User will have to scroll down). What would be great is if the Main Panel Graph just 'switches'. I'm not sure if ConditinalPanel would work here? Or even a Switch statement? Here is my UI.
source("DATA CLEANING.R")
salespeople <- sort(unique(salesdatav3$SALESPERSON))
# Define UI for application that draws a histogram
ui <- fluidPage(theme = shinytheme("united"),
# Application title
titlePanel("Pounds_New"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
pickerInput("slsp", "SalesPerson", choices = salespeople, selected =NULL, options = list(`actions-box` = TRUE), multiple = T),
pickerInput("stats", "Summary Stats", choices = as.vector(c("Positive/Negative Count", "Histogram", "Plot Pounds by Time", "Top Ten Positive Trending",
"Top Ten Negative Trending")), selected = NULL, multiple = F, list(`actions-box` = TRUE))
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("sidebarplot"),
# conditionalPanel(
# condition = "input.stats == 'Histogram'",
# plotOutput("histt"),
# conditionalPanel(
# condition = "input.slsp",
DT::dataTableOutput("data_table"),
plotOutput("plot_pounds")
)
)
)
Yes, you can certainly have conditional panels in the mainPanel plotting area. Your code was quite close to being workable (just one or two errant parentheses). Below is revised code with and dummy plots to show how it works. You'll obviously have to update with what you actually want for plots. The basic structure should be quite clear. In the UI, just include your conditionalPanels in the mainPanel items, and then specify your plots separately in the server.
UI:
library(shiny)
library(shinythemes)
library(shinyWidgets)
ui <- fluidPage(theme = shinytheme("united"),
# Application title
titlePanel("Pounds_New"),
# Sidebar with a slider input for number of bins
sidebarLayout(
sidebarPanel(
pickerInput("slsp", "SalesPerson", choices = c("a","b","c","d"), selected =NULL, options = list(`actions-box` = TRUE), multiple = T),
pickerInput("stats", "Summary Stats", choices = as.vector(c("Positive/Negative Count", "Histogram", "Plot Pounds by Time", "Top Ten Positive Trending",
"Top Ten Negative Trending")), selected = NULL, multiple = F, list(`actions-box` = TRUE))
),
# Show a plot of the generated distribution
mainPanel(
conditionalPanel(
condition = "input.stats == 'Positive/Negative Count'",
plotOutput("sidebarplot")
),
conditionalPanel(
condition = "input.stats == 'Histogram'",
plotOutput("histt")
),
conditionalPanel(
condition = "input.slsp",
# DT::dataTableOutput("data_table"),
plotOutput("plot_pounds")
)
)
)
)
Server:
server <- function(input, output) {
output$sidebarplot <- renderPlot({
hist(rnorm(50),10)
})
output$histt <- renderPlot({
hist(runif(50),10)
})
output$plot_pounds <- renderPlot({
hist(rbeta(50,1,5),10)
})
}
shinyApp(ui, server)

Resources