Is it possible to precompute values for ggplot histogram? Computing a number of histograms is really slowing down my ShinyR app, so I'd like to find a way to cache histograms so they are only computed once for a given set of parameters. I checked the docs but didn't see anything about this. Apologies if I missed something, but could someone point me to documentation about how to do this, or tell me that it's not possible?
You could do something like this:
library(shiny)
library(ggplot2)
n <- 400
server <- function(input, output) {
cachedData <<- list()
datasetInput <- reactive({
switch(input$dataset,
"data1" = list("name"="dataset1", "data"=data.frame("x"=runif(n),"y"=runif(n)), "plot"=NULL),
"data2" = list("name"="dataset2", "data"=data.frame("x"=runif(n),"y"=runif(n)), "plot"=NULL),
"data3" = list("name"="dataset3", "data"=data.frame("x"=runif(n),"y"=runif(n)), "plot"=NULL))
})
observeEvent(input$run,{
d <- datasetInput()
# If dataset cached
if ( d$name %in% names(cachedData) ){
}
# Else cache dataset
else{
cachedData[[d$name]] <<- d
}
# See if data is loaded
if ( is.null( cachedData[[d$name]]$plot ) ){
print("Creating Plot")
cachedData[[d$name]]$plot <<- ggplot(data=d$data,aes(x=x)) + geom_histogram(stat="bin")
}
else{
print("Loading plot")
}
# Else save data
output$plot <- renderPlot({ cachedData[[d$name]]$plot})
})
}
ui <- shinyUI(fluidPage(
selectInput("dataset", "Choose a dataset:",
choices = c("data1", "data2", "data3")),
plotOutput("plot"),
actionButton('run','Generate Plot')
)
)
shinyApp(ui = ui, server = server)
The cachedData list can then be loaded and saved with the load and save functions.
Related
Some days ago I was answered in this post. The solution was perfect in that moment, but I realised that I forgot to ask how I can do that with more than 1 checkboxInput. Since... I have tried a lot of things and that solution doesn't fit me with 2 checkboxInput. Maybe it can be done with the same solution changing some things, but, as I am new using shiny, I cannot find a way to do it.
The difference between the code from the previous post and this one, is that I have added a conditionalPanel and two checkboxInputs instead of 1.
Since the condition here is that if the user selects the condition (play), I thought that the solution was writing eventReactive(input$play,{}). However, none of the checkboxInputs work.
On the other hand, if you write eventReactive(input$change_log2,{}) one of the checkboxInputs (the logaritm) works. But if you select the other (srqt) it won't do nothing.
I have seen that an alternative way could be using observe or observeEvent but I cannot save the results in a variable, so... I need eventReactive...
I am a bit lost.
Someone could help me? Eventually I will add more checkboxInputs... so I need a way which I could use more than 2 checkboxInputs.
Here it is the code:
library(shiny)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("My app"),
sidebarLayout(
sidebarPanel(
uiOutput("selected_sample_one"),
uiOutput("selected_sample_two"),
checkboxInput("play", strong("I want to play my data"), value = FALSE),
conditionalPanel(
condition = "input.play == 1",
checkboxInput("change_log2", "Log2 transformation", value = FALSE),
checkboxInput("run_sqrt", "sqrt option", value = FALSE))
),
# Show a plot of the generated distribution
mainPanel(
plotOutput("plot")
)
)
)
# Define server
server <- function(input, output,session) {
data <- reactive({
numbers <- c(5,345,55,10)
df<-data.frame(t(numbers))
names(df) <- c("S1", "S2", "S3", "S4")
return(df)
})
data1 <- eventReactive(input$play,{
df <- data()
if(input$change_log2 == TRUE){
df <- log2(df)
}
if(input$run_sqrt == TRUE){
df <- sqrt(df)
}
return(df)
})
samples_names <- reactive({
req(data())
samples <- colnames(data())
return(samples)
})
output$selected_sample_one <- renderUI({
selectizeInput(inputId = "sample_one_axis", "Select the 1st sample", choices=samples_names(), options=list(maxOptions = length(samples_names())))
})
# With this function you can select which sample do you want to plot in the y-axis.
output$selected_sample_two <- renderUI({
selectizeInput(inputId = "sample_two_axis", "Select the 2nd sample", choices=samples_names(), selected=samples_names()[2], options=list(maxOptions = length(samples_names())))
})
output$plot <- renderPlot({
req(input$sample_one_axis,input$sample_two_axis,data1())
barplot(c(data1()[,input$sample_one_axis], data1()[,input$sample_two_axis]))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Thanks very much in advance,
Regards
You can simply wrap the relvant inputs in c().
Here's a MWE:
library(shiny)
ui <- fluidPage(
checkboxInput("check1", "Checkbox 1"),
checkboxInput("check2", "Checkbox 2"),
textOutput("text")
)
server <- function(input, output, session) {
v <- reactiveValues(text="Waiting...")
observeEvent(c(input$check1, input$check2), {
s <- "Checked: "
if (input$check1) {
s <- paste(s, "1")
}
if (input$check2) {
s <- paste(s, "2")
}
v$text <- s
},
ignoreInit=TRUE
)
output$text <- renderText({
v$text
})
}
shinyApp(ui, server)
Alternatively, you could perhaps wrap what you need to do in a function and then just call the function in a series of observeEvents, one for each relevant input.
[I started writing before you updated your post.]
Thanks to #Limey, the solution for my problem was to replace data1 <- eventReactive with data1 <- reactive.
Thanks very much.
I want to make a shiny app where the user is able to select genes. Then he will see all the plots for those genes.
The selection part works fine (I think)
ui <- fluidPage(
titlePanel("Test"),
sidebarPanel(
selectInput("genes", "Genes:", seurat_genes, multiple = TRUE),
),
mainPanel(
uiOutput('out1')
)
)
Now I want to those selected genes to be plotted next to the sidebarPanel:
server <- function(input, output) {
output$out1 = renderUI({
p = FeaturePlot(sc, features=input$genes, cols=c("lightgrey", param$col), combine=FALSE)
names(p) = input$genes
for(i in names(p)) {
p[[i]] = plot.mystyle(p[[i]], title=i)
renderPlot(
print(p[[i]])
)
}
})
}
seurat_genes is data from the analysis with Seurat, which is a library for single-cell RNA-seq data. So the user specifies which genes he wants to look at and FeaturePlotgenerates those plots.
FeaturePlot is a function from Seurat which "Colors single cells on a dimensional reduction plot according to a 'feature' (i.e. gene expression, PC scores, number of genes detected, etc.)"
I'm fairly new to R and especially Shiny, so feel free to suggest any kind of improvements.
Found a solution that works for me:
library(shiny)
library(Seurat)
# This Data is from my Workspace. I have trouble loading it, so its a workaround and is my next Problem.
seurat_genes = sc.markers[["gene"]]
# Define UI for application that draws a histogram
ui <- fluidPage(
titlePanel("Einzeldarstellungen von Genen"),
sidebarPanel(
selectInput("genes", "Gene:", seurat_genes, multiple = TRUE),
),
mainPanel(
splitLayout(cellWidths = c("50%","50%"),uiOutput('out_umap'), uiOutput('out_ridge'))
)
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$out_umap = renderUI({
out = list()
if (length(input$genes)==0){return(NULL)}
for (i in 1:length(input$genes)){
out[[i]] <- plotOutput(outputId = paste0("plot_umap",i))
}
return(out)
})
observe({
for (i in 1:length(input$genes)){
local({ #because expressions are evaluated at app init
ii <- i
output[[paste0('plot_umap',ii)]] <- renderPlot({
return(FeaturePlot(sc, features=input$genes[[ii]], cols=c("lightgrey", param$col), combine=FALSE))
})
})
}
})
output$out_ridge = renderUI({
out = list()
if (length(input$genes)==0){return(NULL)}
for (i in 1:length(input$genes)){
out[[i]] <- plotOutput(outputId = paste0("plot",i))
}
return(out)
})
observe({
for (i in 1:length(input$genes)){
local({ #because expressions are evaluated at app init
ii <- i
output[[paste0('plot',ii)]] <- renderPlot({
return(RidgePlot(sc, features=input$genes[[ii]], combine=FALSE))
})
})
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
I want to create a modularized Shiny app where one module, dataUpload, is used to import a CSV and another module, chart, is used to
Create dynamic x and y dropdowns based on the column names within the CSV THIS WORKS
Create a plot based on the selected input$xaxis, input$yaxis This produces the error invalid type/length (symbol/0) in vector allocation
I think the issue is with my reactive ggplot in chart.R and I'd love any help - I added all the info here but I also have a github repo if that's easier I think this could be a really great demo into the world of interacting modules so I'd really appreciate any help!!
App.R
library(shiny)
library(shinyjs)
library(tidyverse)
source("global.R")
ui <-
tagList(
navbarPage(
"TWO MODULES",
tabPanel(
title = "Data",
dataUploadUI("datafile", "Import CSV")
),
tabPanel(
title = "Charts",
chartUI("my_chart")
)
)
)
server <- function(input, output, session) {
datafile <- callModule(dataUpload, "datafile", stringsAsFactors = FALSE)
output$table <- renderTable({ datafile() })
# PASS datafile WITHOUT () INTO THE MODULE
my_chart <- callModule(chart, "my_chart", datafile = datafile)
output$plot <- renderPlot({ my_chart() })
}
shinyApp(ui, server)
dataUpload.R
dataUpload <- function(input, output, session, stringsAsFactors) {
# The selected file, if any
userFile <- reactive({
# If no file is selected, don't do anything
# input$file == ns("file")
validate(need(input$file, message = FALSE))
input$file
})
# The user's data, parsed into a data frame
dataframe <- reactive({
read.csv(userFile()$datapath,
stringsAsFactors = stringsAsFactors)
})
# We can run observers in here if we want to
observe({
msg <- sprintf("File %s was uploaded", userFile()$name)
cat(msg, "\n")
})
# Return the reactive that yields the data frame
return(dataframe)
}
dataUploadUI.R
# The first argument is the id -- the namespace for the module
dataUploadUI <- function(id, label = "CSV file") {
# Create a namespace function using the provided id
#ALL UI FUNCTION BODIES MUST BEGIN WITH THIS
ns <- NS(id)
# Rather than fluidPage use a taglist
# If you're just returning a div you can skip the taglist
tagList(
sidebarPanel(
fileInput(ns("file"), label)),
mainPanel(tableOutput("table"))
)
}
chart.R
I believe this is the file that needs some minor changing in order to have the plot properly render?
chart <- function(input, output, session, datafile = reactive(NULL)) {
# SINCE DATAFILE IS A REACTIVE WE ADD THE PRERENTHESIS HERE
# WHERE/HOW CAN I ACCESS input$xaxis?
# Do I need to use ns? Can you do that in the server side of a module?
output$XAXIS <- renderUI(selectInput("xaxis", "X Axis", choices = colnames(datafile())))
output$YAXIS <- renderUI(selectInput("yaxis", "Y Axis", choices = colnames(datafile())))
# NOT WORKING
# Use the selectInput x and y to plot
p <- reactive({
req(datafile)
# WORKS: ggplot(datafile(), aes(x = Sepal_Length, y = Sepal_Width))
# DOES NOT WORK:
ggplot(datafile(), aes_(x = as.name(input$xaxis), y = as.name(input$yaxis))) +
geom_point()
})
return(p)
}
chartUI.R
chartUI <- function(id, label = "Create Chart") {
ns <- NS(id)
tagList(
sidebarPanel(
uiOutput(ns("XAXIS")),
uiOutput(ns("YAXIS"))
),
mainPanel(plotOutput("plot"))
)
}
We need to manually specify the name space within a renderUI function using session$ns
chart <- function(input, output, session, datafile = reactive(NULL)) {
# SINCE DATAFILE IS A REACTIVE WE ADD THE PRERENTHESIS HERE
# WHERE/HOW CAN I ACCESS input$xaxis?
# Do I need to use ns? Can you do that in the server side of a module?
output$XAXIS <- renderUI(selectInput(session$ns("xaxis"), "X Axis", choices = colnames(datafile())))
output$YAXIS <- renderUI(selectInput(session$ns("yaxis"), "Y Axis", choices = colnames(datafile())))
# NOT WORKING
# Use the selectInput x and y to plot
p <- reactive({
req(datafile)
# WORKS: ggplot(datafile(), aes(x = Sepal_Length, y = Sepal_Width))
# DOES NOT WORK:
ggplot(datafile(), aes_(x = as.name(input$xaxis), y = as.name(input$yaxis))) +
geom_point()
})
return(p)
}
Considering a user filling in by hand a rhandsontable, I would like to implement a time related condition to proceed with table analysis and plot. E.g. if nothing has been added to table during the last 2 seconds, proceed, otherwise await till the 2 seconds are past.
I tried with validate() or simple condition (like below). It does not work because observe() is accessed immediately after table is modified, at that time the time related condition is false. When the condition should be true, the observe() function is not accessed anymore so condition is not tested...
I tried to provide a MRE but I have trouble defending the need for such feature in a simple example. The need is related to computation time of analysis and plot.
library(shiny)
library(rhandsontable)
library(ggplot2)
DF <- data.frame(x=integer(0), y=integer(0))
ui <- shinyUI(fluidPage(
mainPanel(
rHandsontableOutput("hot"),
plotOutput("plot1")
)
))
server <- shinyServer(function(input, output) {
values <- reactiveValues()
values$table <- DF
values$accessDF <- 0
observe({
if (!is.null(input$hot)) {
DF <- hot_to_r(input$hot)
values$accessDF <- Sys.time() # reset awaiting time when table is incremented
} else {
if (is.null(values[["DF"]]))
DF <- DF
else
DF <- values[["DF"]]
}
values[["DF"]] <- DF
})
output$hot <- renderRHandsontable({
rhandsontable(values[["DF"]], stretchH = "all", minRows=5)
})
observe({
if (Sys.time() - values$accessDF > 2){ # unfornate try...
# some modification of the table occuring here
values$table <- values$DF
}
})
output$plot1 <- renderPlot({
ggplot(data=values$table) + geom_line(aes(x=x, y=y))
})
})
shinyApp(ui=ui, server=server)
Another way is to let your plot depend on a debounced reactive expression that contains the reactive value:
library(shiny)
library(rhandsontable)
library(ggplot2)
ui <- shinyUI(fluidPage(
mainPanel(
rHandsontableOutput("hot"),
plotOutput("plot1")
)
))
server <- function(input, output, session) {
rv = reactiveVal(data.frame(x = integer(0), y = integer(0)))
r2 = reactive(rv()) |>
debounce(2000)
output$hot <- renderRHandsontable({
rhandsontable(rv(), stretchH = "all", minRows = 5)
})
output$plot1 <- renderPlot({
ggplot(r2(), aes(x = x, y = y)) +
geom_point(na.rm = TRUE) +
geom_line(na.rm = TRUE)
})
observeEvent(input$hot$changes, {
rv(hot_to_r(input$hot))
})
}
shinyApp(ui = ui, server = server)
I found one solution. Use reactiveTimer() to force the observe() to activate even though no variable it observes has been updated.
in server:
autoInvalidate <- reactiveTimer(200) # to activate observer every 200 ms
and then in observe()
autoInvalidate()
followed by the condition
if (Sys.time() - values$accessDF > 2){ # unfornate try...
# some modification of the table occuring here
values$table <- values$DF
}
see https://shiny.rstudio.com/reference/shiny/1.0.0/reactiveTimer.html
I'd like to create data once and reuse it in multiple plots. The example below creates the data in each plot, but how can I create it once (x) and have each plot use x?
ui <- shinyUI(
fluidPage(
sidebarLayout(
sidebarPanel(
numericInput(inputId = "mean", label = "Mean", value = 50)
),
mainPanel(
column(6,plotOutput(outputId = "hist1")
),
column(6,plotOutput(outputId = "hist2")
)
)
)
)
)
server <- function(input,output){
# I'd like to create the data just once here, and then reuse it in each plot
# x <- rnorm(100,input$mean,5)
output$hist1 <- renderPlot({
hist(rnorm(100,input$mean,5))
#hist(x)
})
output$hist2 <- renderPlot({
hist(rnorm(100,input$mean,5))
#hist(x)
})
}
runApp(list(ui = ui, server = server))
You can wrap your rnorm in a reactive expression to create a reactive conductor. Then, use the conductor in your endpoints (output$). See http://shiny.rstudio.com/articles/reactivity-overview.html.
server <- function(input,output){
# I'd like to create the data just once here, and then reuse it in each plot
x <- reactive(rnorm(100, input$mean, 5))
output$hist1 <- renderPlot({
hist(x())
})
output$hist2 <- renderPlot({
hist(x())
})
}
Wrapping the server codes with observe would do the job.
server <- function(input,output){
# I'd like to create the data just once here, and then reuse it in each plot
observe({
data <- rnorm(100,input$mean,5)
output$hist1 <- renderPlot({
hist(data)
#hist(rnorm(100,x,5))
})
output$hist2 <- renderPlot({
hist(data)
#hist(rnorm(100,x,5))
})
})
}