Shiny: display notification until browser is no longer busy - r

I have a Shiny application that plots large treemaps. I create the treemap objects ahead of time and serialize them:
library(readr)
library(magrittr)
library(highcharter)
library(treemap)
tm_file_name <- function(num_leaves) {
paste0(as.character(num_leaves), "_leaves.rds")
}
create_rand_treemap <- function(num_leaves) {
random.hierarchical.data(n = num_leaves) %>%
treemap(index = c("index1", "index2", "index3"),
vSize = "x",
draw = FALSE) %>%
hctreemap(allowDrillDown = TRUE) %>%
write_rds(tm_file_name(num_leaves))
}
for (leaves in c(50, 500, 5000)) {
create_rand_treemap(leaves)
}
Then I load them like this:
library(shiny)
library(shinydashboard)
library(shinycssloaders)
library(readr)
library(highcharter)
tm_file_name <- function(num_leaves) paste0(as.character(num_leaves), "_leaves.rds")
load_treemap <- function(num_leaves) tm_file_name(num_leaves) %>% read_rds()
ui <- dashboardPage(
dashboardHeader(
title = "Reproducible Shiny Example",
titleWidth = "100%"
),
dashboardSidebar(
radioButtons(
"num_leaves", "Number of Leaves in Treemap:",
c("50" = 50, "500" = 500, "5000" = 5000)
),
actionButton("createTreemap", "Create Treemap")
),
dashboardBody(
# CSS spinner
withSpinner(highchartOutput("treemap", width = "100%", height = "500px"),
type = 7))
)
server <- function(input, output) {
output$treemap <- renderHighchart({
# load and render only on button press
if (length(input$createTreemap) != 0) {
if (input$createTreemap > 0) {
# notification attempt
progress <- shiny::Progress$new()
on.exit(progress$close())
progress$set(message = 'Generating treemap...')
isolate({load_treemap(input$num_leaves)})
}
}
})
}
shinyApp(ui = ui, server = server)
I would like to display a loading notification or spinner until the treemap has fully rendered.
The above example, live here, contains two attempts at this.
The first attempt uses Shiny progress objects to create a notification. However, the notification only displays for a very short time before disappearing. I believe this is because Shiny only has to read a serialized file and then it thinks the task is complete, but it takes the browser a long time to render the plot.
I've also tried a shinycssloaders approach, but
The CSS spinner displays briefly when the application first loads, which I don't want.
The spinner freezes after several seconds when rendering large treemaps (i.e 5000 leaves).
Lastly, I tried some blind copy-pasting from this SO question, but either couldn't get the solutions there to work with shinydashboard or to persist until the rendering was complete.
How can I display Shiny notifications until both Shiny and the browser are no longer busy?

Related

Shiny - elements are not being rendered once function is complete

I am dynamically creating the elements to be inserted into a fluidRow, the problem that I am facing is that all elements are being rendered at once. So, instead of rendering each element when its renderUI function ends, they all keep waiting until the last renderUI finishes. Thus, having lots of elements in my_dataset makes the rendering really slow.
I expected that once the print(str_glue('End: {i}')) was shown, the element would be rendered. However, this was not the case, it kept waiting for all elements (including ones that were not visible on screen).
I tried using the outputOptions(..., suspendWhenHidden = TRUE) but it made no difference (as it was expected since this is the default).
MWE
library(shiny)
library(shinydashboard)
library(dplyr)
library(tidyr)
library(purrr)
library(stringr)
library(shinycssloaders)
qtd <- 500
my_dataset <- data.frame(
stringsAsFactors = F,
Name = rep('Sample', qtd),
Value = runif(qtd)
)
ui <- function() {
fluidPage(
fluidRow(
column(12, textInput(inputId = 'my_text_input', label = NULL, placeholder = 'Search', width = '100%')),
uiOutput('custom_ui')
)
)
}
server <- function(input, output, session) {
output[['custom_ui']] <- renderUI({
filtered_dataset <- my_dataset %>%
filter(grepl(input[['my_text_input']], Name, ignore.case = T)) %>%
arrange(Name)
map(1:nrow(filtered_dataset), function(i) {
item <- filtered_dataset[i,]
custom_id <- str_glue('custom_id_{i}')
output[[custom_id]] <- renderUI({
print(str_glue('Start: {i}'))
print(item)
result <- box(
width = 3,
title = item$Name,
item$Value
)
print(str_glue('End: {i}'))
result
})
column(width = 3, uiOutput(custom_id, style = 'height: 350px;') %>% withSpinner(type = 6))
})
})
}
runApp(shinyApp(ui = ui, server = server), launch.browser = T)
What you are describing is the expected behaviour. The server will not return anything to the UI before all calculations are finished.
I see you are relying a lot on renderUI. This tends to make the Shiny app slow. When the app starts, it must load, realize that it lacks a portion of the UI, ask the server to create the UI - then the server will create the HTML for all of your boxes and send them to the UI before anything is shown. You should try to keep as much as possible of the UI static.
Dependent on what you want to achieve there are probably a lot of different ways of doing it without renderUI.
Under is an example where the HTML for the boxes are created outside of renderUI. This will work, as long as you don't need input controls or outputs in the boxes - because then they need their own ID.
library(shiny)
library(shinydashboard)
library(dplyr)
library(purrr)
qtd <- 500
my_dataset <- data.frame(
stringsAsFactors = FALSE,
Name = rep('Sample', qtd),
Value = runif(qtd)
) %>%
mutate(
x = map2(
Name,
Value,
~column(
width = 3,
box(
width = 3,
title = .x,
.y
)
)
)
)
ui <- function() {
fluidPage(
fluidRow(
column(
12,
textInput(
inputId = 'my_text_input',
label = NULL,
placeholder = 'Search',
width = '100%'
)
),
uiOutput('custom_ui')
)
)
}
server <- function(input, output, session) {
# Only the filtering of the data is done inside `renderUI`
output[['custom_ui']] <- renderUI({
filtered_dataset <-
my_dataset %>%
filter(grepl(input[['my_text_input']], Name, ignore.case = TRUE)) %>%
arrange(Name) %>%
pull(x)
})
}
runApp(shinyApp(ui = ui, server = server), launch.browser = TRUE)
Last I just want to recommend this book by Hadley Wickham. I think reading this (or parts of this) book before working with Shiny will make everything easier for you.
My Shiny application elements are not being rendered once the function is complete. I have a laptop with 2 external monitors. I do Shiny development in the IDE on monitor #1. If I run the app on monitor #1, it takes about 20 seconds to complete rendering when the main calculations (function) have completed. If I run the app on the laptop or monitor #2, it takes about 3 seconds to complete rendering.
However, this is when the app is maximized to full screen. If the app is not maximized, it renders quickly no matter the display (about 3 seconds).
I can only interact with the application on a screen other than the one which displays the IDE, unless it is not maximized. I know this sounds odd but I have tested it many times and it is the only logical solution. Why this is the case I would be interested in finding out.
I have also tried with 'open in browser' enabled, it will render only after about 20 seconds.

why R Shiny Loading Spinner from shinycssloaders is not showing up

I'm trying to add a Loading Spinner on my table output. But the Spinner disappeared when I ues the column name of the table to update the choices of a checkboxGroupInput. Here is a example of the issue.
Is there any way to fix this or are there any other loading icon options?
library(shiny)
library(shinycssloaders)
data(mtcars)
ui <- fluidPage(
actionButton(inputId = 'a', label = 'show dataset'),
checkboxGroupInput(inputId = 'b', label = 'Select Column'),
tableOutput('table')%>% withSpinner(),
)
server <- function(input, output, session) {
data = eventReactive(input$a, {
# Pause for 3 seconds to simulate a long computation.
Sys.sleep(3)
mtcars
})
# loading spin disappear afer I add updateCheckboxGroupInput based on the output data column names
observeEvent(input$a, {updateCheckboxGroupInput(session, 'b', choices = colnames(data()))})
# if updateCheckboxGroupInput does not depend on output data, loading spin will show up
#observeEvent(input$a, {updateCheckboxGroupInput(session, 'b', choices = c('a','b','c'))})
output$table = renderTable({data()})
}
shinyApp(ui = ui, server = server)
You have an extra comma on this line:
tableOutput('table')%>% withSpinner(),
Just incase anyone else looks at this, the example is also using pipes, i.e. %>%, but no package that adds them. You can switch to withSpinner(tableOutput('table')) or include library(magrittr)

R Shiny data table images not updating when running in browser

I'm creating a Shiny app which displays images and text in a data table. This table will need to update depending on the user's input. When I run the app in a window the table updates as expected. However, when I run it in a browser the text updates but the image does not. How do I make it work in a browser?
EDIT: For clarity, the below example is just to reproduce the issue. The real app could display any number of different pictures, which aren't saved locally until the user makes a selection (they're pulled from a database). I was hoping to avoid having different filenames because I could potentially end up with hundreds of thousands of pictures saved locally, but if that's the only solution then I will have to cleanup the folder periodically
Reproducible example (requires 2 local images)
library(shiny)
library(imager)
library(DT)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Tables to export"),
sidebarLayout(
sidebarPanel(
actionButton("pic1","Pic1"),
actionButton("pic2","Pic2")
),
# Show tables
mainPanel(
fluidRow(
dataTableOutput('tab1')
)
)
)
)
# Define server logic
server <- function(input, output) {
observeEvent(input$pic1, {
pic <- load.image("www/pic1.png")
save.image(pic,"www/picToShow.png")
tab1 <- datatable(t(data.frame("Pic"='<img src="picToShow.png" width=150 height=100>',x1=1,x2=2,x3=3,row.names="p1")),
escape = F, options = list(dom = 't',pageLength = 20))
output$tab1 <- renderDataTable(tab1)
})
observeEvent(input$pic2, {
pic <- load.image("www/pic2.png")
save.image(pic,"www/picToShow.png")
tab1 <- datatable(t(data.frame("Pic"='<img src="picToShow.png" width=150 height=100>',x1=4,x2=5,x3=6,row.names="p1")),
escape = F, options = list(dom = 't',pageLength = 20))
output$tab1 <- renderDataTable(tab1)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Expected behaviour (behaviour in window)
Behaviour in the browser
I agree with #MrFlick's comment. Why do you load both images and resave them with the same name? The browser will think that it knows the image already and will re-use the already loaded image.
Why not just include pic1.png and pic2.png directly?
server <- function(input, output) {
observeEvent(input$pic1, {
tab1 <- datatable(t(data.frame("Pic"='<img src="pic1.png" width=150 height=100>',x1=1,x2=2,x3=3,row.names="p1")),
escape = F, options = list(dom = 't',pageLength = 20))
output$tab1 <- renderDataTable(tab1)
})
observeEvent(input$pic2, {
tab1 <- datatable(t(data.frame("Pic"='<img src="pic2.png" width=150 height=100>',x1=4,x2=5,x3=6,row.names="p1")),
escape = F, options = list(dom = 't',pageLength = 20))
output$tab1 <- renderDataTable(tab1)
})
}
library(shiny)
library(imager)
library(DT)
# Define UI
ui <- fluidPage(
# Application title
titlePanel("Tables to export"),
sidebarLayout(
sidebarPanel(
actionButton("pic1","Pic1"),
actionButton("pic2","Pic2")
),
# Show tables
mainPanel(
fluidRow(
DT::dataTableOutput('tab1')
)
)
)
)
# Define server logic
server <- function(input, output) {
vals = reactiveValues(pic1 = 0, pic2 = 0)
observeEvent(input$pic1, {
vals$pic1 <- 1
vals$pic2 <- 0
})
observeEvent(input$pic2, {
print(vals$pic1)
print(vals$pic2)
vals$pic1 <- 0
vals$pic2 <- 1
})
dynamicdf <- reactive({
if(vals$pic1 == 1) {
df <- data.frame(
pic = c('<img src="http://flaglane.com/download/american-flag/american-flag-large.png" height="52"></img>'),
x1 = c(1),
x2 = c(2),
x3 = c(3)
)
} else {
df <- data.frame(
pic = c('<img src="img2.jpg" width=150 height=100></img>'),
x1 = c(4),
x2 = c(5),
x3 = c(6)
)
}
print(df)
return(df)
})
output$tab1 <- DT::renderDataTable({
DT::datatable(dynamicdf(), escape = FALSE)
})
}
# Run the application
shinyApp(ui = ui, server = server)
In Shiny Apps you do not load or saves images. You display them by using a path to the folder, where your pictures are stored. This can be a Link on the internet or a path on your machine.
Do it like this. I use a reactiveValue to track the last click of your button. This is a good solution if you have a large number of pictures you may want to render. (I adopted that style from the modern JS Library ReactJS) Based on the state you display your pictures. Do NOT use the www path, this is already expected by shiny. Leave it as in the example2 in the App.
For me it also only worked with the escape = FALSE parameter in the App. Try that if it does not work without it.

R Shiny Leaflet Map won't redraw after the first movement

I have been working on my first little project in R and have run into an issue with a Leaflet map. It will render properly with the data and design I have specified thus far, but once I move the map in browser or the R viewer in RStudio it will no longer react to clicks/drags/etc. and will not react even if it is left alone for several minutes.
I have also had an issue with the zoom functionality, I am not sure if this is due to something that I missed or something to do with the above issue.
Example of the data:
Data_example
# Libraries ---------------------------------------------------------------
library("shiny")
library("tidyverse")
library("leaflet")
library("leaflet.minicharts")
# UI ----------------------------------------------------------------------
ui <- fluidPage(
titlePanel("Wiersma Sale Iceland Trip"),
mainPanel(
leafletOutput(outputId = "Map_1", height = 1080, width = 1920)
)
)
# Server ------------------------------------------------------------------
server <- function(input, output) {
sheets_data <- read.csv("Iceland_Mark2 - Data.csv")
output$Map_1 <- renderLeaflet({
m <- leaflet(data = sheets_data) %>%
addTiles() %>%
addMinicharts(
sheets_data$Long,
sheets_data$Lat,
type = "pie",
popup = popupArgs(
labels = c("A", "B", "C"),
html = paste0(
"<div>",
"<h3>",
sheets_data$Name,
"</h3>",
"Description: ",
sheets_data$Description,
"<br>",
"Media_1: ",
sheets_data$Media_1,
"</div>"
)
)
)
})
}
# Run_App -----------------------------------------------------------------
shinyApp(ui = ui, server = server)
The output:
Output_of_app
It needn't be pretty, nor unique, but it does need to react to zooming and movement and I can't for the life of me figure out why it behaves this way.
I had the same problem suddenly come up after having already produced a number of maps with no issues. So I figured it most likely was to do with the data I was feeding it.
I had one row in my chartdata that had NAs. Deleting this row and remapping fixed the problem.

Interactive Column/Table Updates with textInput in R Shiny

UPDATE
I've gotten to what I think is the root problem. The following R Shiny App produces a UI with 2 text input boxes, as well as event observers that print messages to the console as the text changes in their respective text input boxes. The issue is that only one of these event observers works correctly, and I can't figure out why.
ui.R (shortened)
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
shinyUI(
renderUI({
fluidPage(
column(12, dataTableOutput("Main_table")),
box(textInput("TEST_BOX", label=NULL, value="TEST"))
)
})
)
server.R (shortened)
shinyServer(function(input, output) {
test <- reactiveValues()
test$data <- data.table(ID = 1, Group = 1)
output$Main_table <- renderDataTable({
datatable(data.frame(test$data,
New_Group=as.character(textInput("BOX_ID", label = NULL, value = "TEST2",
width = '100px'))), escape=F
)})
observeEvent(input$TEST_BOX, {
print("Test Box Success")
})
observeEvent(input$BOX_ID, {
print("Box ID Success")
})
})
Original Post:
I'm attempting to create a simple app in R Shiny to allow the user to interactively update the values in a column of a small table, then be able to hit a "Save Changes" button and update the table to include their selections.
I've gotten really close with the code below (I think), but for some reason the inputs cbox_1 to cbox_10 always come back as NULL.
ui.R
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
shinyUI(fluidPage(
dashboardBody(uiOutput("MainBody")
)
))
server.R
# Load libraries
library(shiny)
library(shinydashboard)
library(DT)
library(data.table)
# Define server logic
shinyServer(function(input, output) {
# Create sample data
vals <- reactiveValues()
vals$Data <- data.table(ID = 1:10, Group = 1:1)
# Create main UI with Save Changes button and additional text input box for testing.
output$MainBody <- renderUI({
fluidPage(
box(width=12,
h3(strong("Group Testing"),align="center"),
hr(),
box(textInput("test", label=NULL, value="TESTING")),
column(6, offset = 5, actionButton("save_changes","Save changes")),
column(12, dataTableOutput("Main_table"))
)
)
})
# Function to be used to create multiple text input boxes.
shinyInput = function(FUN, len, id, ...) {
inputs = character(len)
for (i in seq_len(len)) {
inputs[i] = as.character(FUN(paste0(id, i), label = NULL, value = vals$Data$Group[i], width = '100px', ...))
}
inputs
}
# Renders table to include column with text input boxes. Uses function above.
output$Main_table <- renderDataTable({
datatable(data.frame(vals$Data, New_Group=shinyInput(textInput, nrow(vals$Data),"cbox_")), options = list(dom = 't', pageLength = nrow(vals$Data), paging=FALSE, searching=FALSE), rownames=FALSE,
escape=F)
}
)
# Tests if the test input box works.
observeEvent(input$test, {
print("Success1")
})
# Tests if the first input box in the table works.
observeEvent(input$cbox_1, {
print("Success2")
})
# Tests if the Save Changes button works.
observeEvent(input$save_changes, {
print("Success3")
# Assigns the values in the input boxes (New_Group) to the existing Group column.
for (i in 1:nrow(vals$Data)) {
vals$Data$Group[i] <- eval(paste0("input$cbox_", i))
}
datatable(data.frame(vals$Data, New_Group=shinyInput(textInput, nrow(vals$Data),"cbox_")), options = list(pageLength = nrow(vals$Data), paging=FALSE, searching=FALSE), rownames=FALSE,
escape=F)
})
})
The first two observeEvents at the end of the code are solely for testing purposes. "Success2" is never printed even when the contents of the first box are changed. "Success1" is printed when the test box is changed, but I'm not sure why one works and the other doesn't. I've tried inserting a browser() statement in various places of the code to check the value of cbox_1, but it always comes back NULL. I'd also be open to alternate solutions to this problem if I'm approaching it completely wrong. Thanks.
After further research, an approach utilizing the rhandsontable package seemed like the best solution. I modeled my code after this example:
Data input via shinyTable in R shiny application
I also utilized several of the options described here:
https://jrowen.github.io/rhandsontable/#introduction

Resources