Could anyone can tell me why I get an error when I change a dataset in first selectInput widget? When I change a dataset from diamonds to mtcars I get an error Could not find 'carat' in input$bins and in the plot just for one second and after that everything works fine. Why it happened?
library(shiny)
library(ggplot2)
data(diamonds)
data(mtcars)
ui <- fluidPage(
column(3,
selectInput("data", "", choices = c('mtcars', 'diamonds')),
uiOutput('server_cols'),
uiOutput('server_bins')
),
column(9,
plotOutput("plot")
)
)
server <- function(input, output) {
data <- reactive({
switch(input$data,
diamonds = diamonds,
mtcars = mtcars)
})
output$server_cols <- renderUI({
data <- data()
nam <- colnames(data)
selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
})
output$server_bins <- renderUI({
if (!is.null(input$cols)) {
df <- data()
x <- eval(input$cols)
max_value <- max(df[,x])
sliderInput('bins','Choose number of bins:', min = 0.1,
max = max_value,
value = max_value/2)
}
})
output$plot <- renderPlot({
if (!is.null(input$cols) & !is.null(input$bins)) {
basicData <- data()
var <- eval(input$cols)
ggplot(basicData, aes_string(var)) +
geom_histogram(binwidth = input$bins, color = 'white', fill = 'red')
}
})
}
shinyApp(ui, server)
Your respective output objects respond to any changes of your input variables. Thus, when you change your dataset via input$data, the plot rebuilds itself, although input$cols did not yet adjust. Actually, try inserting some print("a") inside the output$plot to see that it is called up to three times if you change input$data.
The fix is to rethink your reaction logic and let your elements respond only to specific changes, to get some kind of response "thread".
For example, input$data should only trigger output$server_cols. And output$server_bins should only be triggered by input$cols (because this already implies that input$data changed earlier). Ultimately, output$plot just has to listen to changes of input$bins (because changes in input$cols and input$data always result in changes of input$bins since it is at the end of the thread).
Here is my suggestion using isolate.
library(shiny)
library(ggplot2)
data(diamonds)
data(mtcars)
ui <- fluidPage(
column(3,
selectInput("data", "", choices = c('mtcars', 'diamonds')),
uiOutput('server_cols'),
uiOutput('server_bins')
),
column(9,
plotOutput("plot")
)
)
server <- function(input, output) {
data <- reactive({
switch(input$data, diamonds = diamonds, mtcars = mtcars)
})
output$server_cols <- renderUI({
data <- data()
nam <- colnames(data)
selectInput('cols', "Choose numeric columns:", choices = nam[sapply(data, function(x) is.numeric(x))])
})
output$server_bins <- renderUI({
if (!is.null(input$cols)) {
df <- isolate(data())
x <- eval(input$cols)
max_value <- max(df[,x])
sliderInput('bins','Choose number of bins:', min = 0.1, max = max_value, value = max_value/2)
}
})
output$plot <- renderPlot({
if (!is.null(isolate(input$cols)) & !is.null(input$bins)) {
basicData <- isolate(data())
var <- eval(isolate(input$cols))
ggplot(basicData, aes_string(var)) +
geom_histogram(binwidth = input$bins, color = 'white', fill = 'red')
}
})
}
shinyApp(ui, server)
You might also want to look into updateSelectInput and updateSliderInput if you want to alter Input Elements depending on other input.
Related
I am trying to make an RShiny app that you can pick a gene from a list, and it will display different graphs using that gene's transcripts. However, each gene has a different number of transcripts, so a different number of graphs must be displayed every time a different gene is chosen. How I have it set right now is that when a person chooses a gene, a new table is created with the transcript numbers (data to be plotted) along with a new list of all the transcript names (length of this list is the amount of plots that I need). These are reactive values.
Below, in the server, I made a function that creates the graph that I want, and then I iterate through the creation of the function by indexing into the reactive list of names, so it creates a graph for each name (as each name is a different transcript). Right now, the code iterates through all the names correctly but only displays the last plot. Is there a way to have every plot displayed? I have tried a lot of different things, from renderUI to using local calls, but cannot figure it out.
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("var", label = "Choose a gene to display", names),
mainPanel(
plotOutput("tdot"))
))
server <- function(input, output) {
genename <- reactive({
input$var
})
transTable2 <- reactive ({
cbind(biofluids, select(transTable, starts_with(input$var)))
})
names <- reactive ({
tableBF <- cbind(biofluids, select(transTable, starts_with(input$var)))
n <- colnames(tableBF)
final <- n[-1]
})
createUI <- function(name, table) {
ggplot(table, aes_string(x = "biofluids", y = name))+geom_boxplot(aes(color = biofluids))+
geom_boxplot(aes(fill = biofluids)) + scale_y_log10()+ylab( 'log10 normalized counts')+
ggtitle(name)}
output$tdot <- renderPlot({
lapply(1:length(names()), function(i)
createUI(names()[i], transTable2()))
})
}
# Run the application
shinyApp(ui = ui, server = server)
A reproducible example is as follows with the iris dataset, which would have the user select a category (either "Sepal" or "Petal"), and then create a plot for every column in the dataset that starts with that word:
cats <- c("Sepal", "Petal")
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput("var", label = "Choose a category to display", cats),
mainPanel(
plotOutput("tdot"))
))
server <- function(input, output) {
category <- reactive({
input$var
})
iris2 <- reactive ({
select(iris, starts_with(input$var))
})
names <- reactive ({
table2 <- select(transTable, starts_with(input$var))
n <- colnames(table2)
})
createUI <- function(name, table) {
ggplot(table, aes_string(x = "species", y = name))+geom_boxplot(aes(color = species))+
geom_boxplot(aes(fill = species)) + scale_y_log10()+ylab( 'log10 normalized counts')+
ggtitle(name)}
output$tdot <- renderPlot({
lapply(1:length(names()), function(i)
createUI(names()[i], iris2()))
})
}
# Run the application
shinyApp(ui = ui, server = server)
The following code generates dynamic number of outputs with iris data. You should be able to adapt this to your data.
library(shiny)
library(tidyverse)
# Load data
data("iris")
# Add row id
iris2 <- iris %>% mutate(ID = 1:n())
# ui
ui <- fluidPage(
sidebarPanel(
selectInput(inputId = "sel", label = "Select one or more parameters",
choices = names(iris2), multiple = TRUE)
),
mainPanel(
uiOutput("plots")
)
)
# server
server <- function(input, output, session){
# Dynamically generate the plots based on the selected parameters
observe({
req(input$sel)
lapply(input$sel, function(par){
p <- ggplot(iris2, aes_string(x = "ID", y = par)) +
geom_boxplot(aes(fill = Species, group=Species, color=Species)) +
ggtitle(paste("Plot: ", par))
output[[paste("plot", par, sep = "_")]] <- renderPlot({
p
},
width = 380,
height = 350)
})
})
# Create plot tag list
output$plots <- renderUI({
req(input$sel)
plot_output_list <- lapply(input$sel, function(par) {
plotname <- paste("plot", par, sep = "_")
plotOutput(plotname, height = '250px', inline=TRUE)
})
do.call(tagList, plot_output_list)
})
}
shinyApp(ui, server)
It gives the following output:
I went a totally different direction in this project -- the issue I have is down at the end I need to clear out the graph when a different variable is selected. The graph as it is stays the same. Thanks.
I am not even sure how this would be phrased in the documents -- rewriting graphs, dynamic plotting ??? I saw display.removePlot(display.activePlotIndex()) but am not sure about that -- what do I look up to figure this out?
library(shiny)
library(DT)
library(ggplot2)
oboler_data <- read_csv(file = "C:/Users/12083/Desktop/ref.csv")
rdate <- as.Date(oboler_data$DATE,"%m/%d/%y")
ui <- fluidPage(sidebarLayout(
sidebarPanel(
selectInput("dataset", "choose a dataset", c("oboler_data")),
selectInput("column", "Type of Transaction", "placeholder1"),
selectInput("level", "select level", "placeholder2")
),
mainPanel(tableOutput("table"), plotOutput("Histo"))
))
server <- function(input, output, session){
dataset <- reactive({
get(input$dataset)
})
observe({
updateSelectInput(session, "column", choices = names(dataset()))
})
observeEvent(input$column, {
column_levels <- as.character(sort(unique(
dataset()[[input$column]]
)))
updateSelectInput(session, "level", choices = column_levels)
})
output$table <- renderTable({
subset(dataset(), dataset()[[input$column]] == input$level)
})
DF <- data.frame(Name = LETTERS[1:10], Value = rnorm(20), Value2 = runif(20))
output$TableOut <- renderDataTable({
DF
})
output$Histo <- renderPlot({
ggplot(DF, aes(Value)) + geom_histogram(binwidth = 0.1,
fill = "blue", color = "white")
})
}
shinyApp(ui, server)
I think you should use req, as it precludes (and clears!) rendering of a plot if conditions are not met.
library(shiny)
shinyApp(
ui = fluidPage(
checkboxInput("cb", "Plot?"),
sliderInput("cyls", "Cylinders", min = 1, max = 8, value = 4, step = 1),
plotOutput("plt")
),
server = function(input, output, session) {
output$plt <- renderPlot({
req(input$cb, input$cyls)
ggplot(mtcars[mtcars$cyl >= input$cyls,,drop = FALSE],
aes(disp, mpg, color = factor(cyl))) +
geom_point()
})
}
)
The three screenshots above are in sequence: start with "Plot?" deselected, no plot shown; select it, plot appears; deselect it, existing plot disappears.
The way you adapt this to you is to replace the req(input$cb) with something that matches your condition of "clear the plot". (I also included input$cyls here just to prevent larger more-complex apps from reaching the plot block before all inputs have stabilized. Perhaps not required in most apps, but it's a defensive move that carries little consequence if it is overkill, but lots of benefit when it is needed.)
A slight modification on a theme, "telling the user why the plot disappeared". Replace the req with a validate and at least one need:
# req(input$cb, input$cyls)
validate(
need(input$cb, "You deselected \"Plot!\"")
)
I have found the solution in the first answer to this question (checkboxGroupInput - set minimum and maximum number of selections - ticks) does not work as expected. The reproducible example is as follows:
rm(list = ls())
library(shiny)
my_min <- 1
my_max <- 3
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
checkboxGroupInput("SelecetedVars", "MyList:",paste0("a",1:5), selected = "a1")
),
mainPanel(textOutput("Selected"))
)
)
server <- function(input, output,session) {
output$Selected <- renderText({
paste(input$SelecetedVars,collapse=",")
})
observe({
if(length(input$SelecetedVars) > my_max)
{
updateCheckboxGroupInput(session, "SelecetedVars", selected= tail(input$SelecetedVars,my_max))
}
if(length(input$SelecetedVars) < my_min)
{
updateCheckboxGroupInput(session, "SelecetedVars", selected= "a1")
}
})
}
shinyApp(ui = ui, server = server)
When selecting checkboxes as you go down the list new selections are added to the tail of the input$SelectedVars vector and thus the tail(input$SelecetedVars,my_max) returns the last three vars the user selected. However as you go back up the list the vars are added to the head of the input$SelectedVars vector so tail(input$SelecetedVars,my_max) continues to return the vars already selected.
My current patch to this is to add a note on my app that says only three vars can be selected at a time. However this relies on the user to understand they have to un-check variables themselves. So for the sake of simplicity I am wondering if there is a way to have the most recent selected var to be appended to the tail of the vector so you can always display the last vars the user selected.
EDIT 2020/12/17: Including new reprex to illustrate infinite cycling produced from #Ben's 2020/12/16 edit. I removed the min vars as well as this wont be used in my case.*
library(shiny)
library(shinyjs)
library(tsibble)
library(tsibbledata)
library(tidyr)
library(plotly)
df <- aus_production # demo data from tsibbledata package
my_max <- 2
vars_list <- c("Beer", "Tobacco", "Bricks", "Cement", "Electricity", "Gas")
ui <- fluidPage(
useShinyjs(),
sidebarLayout(
sidebarPanel(
checkboxGroupInput("SelectedVars", "MyList:",vars_list, selected = "Beer")
),
mainPanel(
plotlyOutput("plot1", height = "40vh"),
textOutput("Selected"))
)
)
server <- function(input, output,session) {
last_checked <- reactiveVal("Business")
output$Selected <- renderText({
paste(input$SelectedVars,collapse=",")
})
observeEvent(input$SelectedVars, {
shinyjs::disable("SelectedVars")
s <- input$SelectedVars
isolate({
if(length(s) > my_max)
{
removed <- last_checked()[1]
} else {
removed <- c(setdiff(last_checked(), s))
}
Sys.sleep(.5)
complete <- c(last_checked(), c(setdiff(s, last_checked())))
last_checked(complete[!complete %in% removed])
updateCheckboxGroupInput(session, "SelectedVars", selected = last_checked())
shinyjs::enable("SelectedVars")
})
}, ignoreInit = TRUE, ignoreNULL = FALSE)
output$plot1 <- renderPlotly({
req(input$SelectedVars)
vars <- input$SelectedVars
df_plot <- df %>%
select(Quarter:Tobacco)
if(length(input$SelectedVars) == 2){
plot_ly(data = df_plot,
type = "scatter",
mode ="lines"
) %>%
add_trace(x = ~Quarter,
y = ~df_plot[[2]]) %>%
add_trace(x = ~Quarter,
y = ~df_plot[[3]])
} else {
plot_ly(df_plot) %>%
add_lines(x = ~Quarter,
y = ~df_plot[[2]])
}
})
}
shinyApp(ui = ui, server = server)
I'm trying to build a simple application that draws a histogram of a selected variable based on a subset filtered by the other input. I get the error in the line hist(dataX()$datasetInput()) which should return dataX$mpg. How can I fix it?
Full code:
library(shiny)
u <- shinyUI(pageWithSidebar(
headerPanel("Staz w bezrobociu"),
sidebarPanel(
selectInput("variable", "Variable:",
list("Milles/gallon",
"Horse power")
),
textInput("nc","Number of cylinders",value = 6)
),
mainPanel(
plotOutput("Plot")
)
))
s <- shinyServer(function(input, output)
{
dataX <- reactive({mtcars[mtcars$cyl==input$nc,,drop = FALSE]})
datasetInput <- reactive({
switch(input$variable,
"Milles/gallon" = mpg,
"Horse power" = hp)
})
output$Plot <- renderPlot({
hist(dataX()$datasetInput())
})
})
shinyApp(u,s)
You complicated the simple app.
You do not need to list all the columns in selectInput. You can just render it from the server side.
Same applies to the cylinders
Shortcuts like u and sare acceptable, but just stick to the naming conventions. It makes your life easy.
Below is a complete working app
library(shiny)
ui <- shinyUI(pageWithSidebar(
headerPanel("Staz w bezrobociu"),
sidebarPanel(uiOutput("SelectColname"),
uiOutput("Cylinders")),
mainPanel(plotOutput("Plot"))
))
server <- shinyServer(function(input, output){
# Create a reactive dataset
dataX <- reactive({
mtcars
})
# Output number cylinders as select box
output$Cylinders <- renderUI({
selectInput("cylinders", "cylinders:", unique(dataX()$cyl))
})
# Output column names as selectbox
output$SelectColname <- renderUI({
selectInput("variable", "Variable:", colnames(dataX()[,c(1,4)]))
})
# Based on the selection by user, create an eventreactive plotdata object
plotdata <- eventReactive(input$cylinders, {
plotdata = dataX()[dataX()$cyl == input$cylinders, , drop = FALSE]
})
# Render the plot, the plot changes when new cylinder is selected
output$Plot <- renderPlot({
if (is.null(plotdata()))
return(NULL)
hist(
plotdata()[, input$variable],
xlab = input$variable,
main = paste(
"Histogram of" ,
input$variable
)
)
})
})
shinyApp(ui, server)
Setup: I already have build a shiny-app with two plots. I used the flexdashboard-package to create two plots in two tabs. In addition I programmed the whole shiny-app in R-markdown.
Now I want to create an interface where the user can subset the data. That part itself works. However I also need to perform some calculations with the subsetted data, before I do my two plots.
Is there any way I can transform some subsetted object like mydata to a dataframe? My problem is that I need to use this subsetted object also in the UI part of the other plots.
EDIT: I specifically need some way to transport my selection from checkboxGroupInput to selectInput("cat_1"," category 1:",choices = levels(mydata()$mycat).
### 1. Create some sample data
myrows<-sample(letters,12)
exdata<- data.frame(mycat=rep(myrows,2),yr=rep(1:2,each=12),KPI_1=rnorm(24),
KPI_2=round(runif(24,1,20)),KPI_3=rbinom(24,6,0.5))
### 2. UI part
fluidPage(fluidRow(
checkboxGroupInput("comp", "Categories",myrows,myrows,inline=TRUE),
actionButton("go", "Update"),
textOutput("txt"),
tableOutput("head"))
)
### 3. Server part
mydata<-eventReactive(input$go,{
res<-subset(exdata,mycat%in%input$comp)
return(res)
})
output$txt <- renderText({
paste("You chose", paste(input$comp, collapse = ", "))
})
output$head <- renderTable({
mydata()
})
In the next chunk I do this:
library(plotly)
library(shiny)
### 4. UI part of my plot
fluidRow(sidebarLayout(sidebarPanel(
selectInput("cat_1",
" category 1:",
choices = levels(mydata()$mycat),
selected = levels(mydata()$mycat)[1]),
selectInput("cat_2",
" category 2:",
choices = levels(mydata()$mycat),
selected = levels(mydata()$mycat)[2])),
mainPanel(plotlyOutput("plot3", height = 300, width = 700))))
### 5. Server part of my plot
output$plot3 <- renderPlotly({
## 5.1 Create plot data
cat1<-input$cat_1
cat2<-input$cat_2
y1<-as.numeric(mydata()[mydata()$mycat==cat1])
y2<-as.numeric(mydata()[mydata()$mycat==cat2])
x0<-c(1,2)
## 5.2 Do plot
plot_ly(x = x0,y = y1, type="scatter",mode='lines+markers',name=Firm1) %>%
add_trace(y = y2, name = Firm2, mode = 'lines+markers') %>%
layout(dragmode = "select")
It took me a while to figure out your code. So:
1) Make use of renderUI which will allow you to dynamically create controls
2) Stick with one ui
3) Make sure you understand the renderPlotly and what you're trying to plot
library(shiny)
library(plotly)
### 1. Create some sample data
myrows<-sample(letters,12)
exdata<- data.frame(mycat=rep(myrows,2),yr=rep(1:2,each=12),KPI_1=rnorm(24),
KPI_2=round(runif(24,1,20)),KPI_3=rbinom(24,6,0.5))
ui <- fluidPage(
sidebarPanel(
uiOutput("c1"),uiOutput("c2")),
mainPanel(
column(6,
checkboxGroupInput("comp", "Categories",myrows,myrows,inline=TRUE),
actionButton("go", "Update"),
textOutput("txt"),
tableOutput("head")),
column(6,
plotlyOutput("plot3", height = 300, width = 700)))
)
server <- function(input, output) {
### 3. Server part
mydata <- eventReactive(input$go,{
res<-subset(exdata,mycat%in%input$comp)
return(res)
})
output$txt <- renderText({
paste("You chose", paste(input$comp, collapse = ", "))
})
output$head <- renderTable({
mydata()
})
conrolsdata <- reactive({
unique(as.character(mydata()$mycat))
})
output$c1 <- renderUI({
selectInput("cat_1", "Variable:",conrolsdata())
})
output$c2 <- renderUI({
selectInput("cat_2", "Variable:",conrolsdata())
})
output$plot3 <- renderPlotly({
if(is.null(input$cat_1)){
return()
}
y1<- mydata()$KPI_1[as.character(mydata()$mycat) %in% input$cat_1]
y2<- mydata()$KPI_2[as.character(mydata()$mycat) %in% input$cat_2]
x0<-c(1,2)
#use the key aesthetic/argument to help uniquely identify selected observations
plot_ly(x = x0,y = y1, type="scatter",mode='lines+markers',name="Firm1") %>%
add_trace(y = y2, name = "Firm2", mode = 'lines+markers') %>%
layout(dragmode = "select")
})
}
shinyApp(ui, server)