I have several Shiny apps that generate plots with dynamic width/height based on the window size.
My intention has always been to combine all the apps into one app using a combination of navbar, navlist, tabPanel, and modules as specified here.
A working example is given below, without utilizing modules:
library(shiny)
library(plotly)
# ui.R file below
ui <- shinyUI(fluidPage(
tags$head(tags$script('
var dimension = [0, 0];
$(document).on("shiny:connected", function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
});
$(window).resize(function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
});
')),
navlistPanel(
tabPanel("Dynamic Dimensions",
plotlyOutput("myPlot")
)
)
)
)
# server.R file below
server <- function(input, output) {
output$myPlot <- renderPlotly({
plot_ly(midwest, x = ~percollege, color = ~state, type = "scatter",
width = (0.6 * as.numeric(input$dimension[1])),
height = (0.75 * as.numeric(input$dimension[2])))
})
}
# Typically I replace below with run.R file and launch the app in browser
shinyApp(ui = ui, server = server)
Due to the large number of app components I'm combining, I've modularized most of my code. This is where I'm having trouble calling the dimensions variable, even when I wrap it in the ns function (it appears the dimension is being ignored). Below is the entirety of my code, unsuccessfully converted from the above working app. This actually does work, but the width is not correctly updated:
myPlot modules:
myPlotUI <- function(id, label = "My Plot"){
ns <- NS(id)
tags$head(tags$script("
var dimension = [0, 0];
$(document).on('shiny:connected', function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange('dimension', dimension);
});
$(window).resize(function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange('dimension', dimension);
});
"))
tagList(
plotlyOutput(ns("myPlot"))
)
}
myPlot <- function(input, output, session){
ns <- session$ns
output$myPlot <- renderPlotly({
plot_ly(midwest, x = ~percollege, color = ~state, type = "scatter",
width = (0.6 * as.numeric(input$dimension[1])),
height = (0.75 * as.numeric(input$dimension[2])))
})
}
Server, UI, and shinyApp:
server <- function(input, output, session){
callModule(myPlot, "myPlot")
}
# ui.R file below
ui <- shinyUI(fluidPage(
# I've tried putting the js code in this section of the UI. Didn't work...
navlistPanel(
tabPanel("Dynamic Dimensions",
myPlotUI("myPlot")
)
)
)
)
shinyApp(ui = ui, server = server)
Any tips on how I can access the window dimensions within a modularized plot object? Thanks!
The issue is that input values accessed by modules are namespaced, while the input values set by Shiny.onInputChange are not.
So in the myPlot module, input$dimension gets myPlot-dimension but the input is actually just dimension.
One solution would be to make the namespaced id available to the script:
library(shiny)
library(plotly)
myPlotUI <- function(id, label = "My Plot") {
ns <- NS(id)
dimensionId <- ns("dimension")
tagList(
tags$head(tags$script(sprintf("
var dimensionId = '%s';
var dimension = [0, 0];
$(document).on('shiny:connected', function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange(dimensionId, dimension);
});
$(window).resize(function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange(dimensionId, dimension);
});
", dimensionId))),
plotlyOutput(ns("myPlot"))
)
}
myPlot <- function(input, output, session) {
ns <- session$ns
output$myPlot <- renderPlotly({
plot_ly(midwest, x = ~percollege, color = ~state, type = "scatter",
width = (0.6 * as.numeric(input$dimension[1])),
height = (0.75 * as.numeric(input$dimension[2])))
})
}
server <- function(input, output, session){
callModule(myPlot, "myPlot")
}
ui <- fluidPage(
navlistPanel(
tabPanel("Dynamic Dimensions",
myPlotUI("myPlot"))
)
)
shinyApp(ui = ui, server = server)
Another solution that comes with a disclaimer: DANGER, undocumented, abuse-prone feature! You can actually get the root session from a module through session$rootScope(). Would not recommend unless you really have to, but just FYI.
library(shiny)
library(plotly)
myPlotUI <- function(id, label = "My Plot") {
ns <- NS(id)
tagList(
tags$head(tags$script("
var dimension = [0, 0];
$(document).on('shiny:connected', function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange('dimension', dimension);
});
$(window).resize(function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange('dimension', dimension);
});
")),
plotlyOutput(ns("myPlot"))
)
}
myPlot <- function(input, output, session) {
ns <- session$ns
rootInput <- session$rootScope()$input
output$myPlot <- renderPlotly({
plot_ly(midwest, x = ~percollege, color = ~state, type = "scatter",
width = (0.6 * as.numeric(rootInput$dimension[1])),
height = (0.75 * as.numeric(rootInput$dimension[2])))
})
}
server <- function(input, output, session){
callModule(myPlot, "myPlot")
}
ui <- fluidPage(
navlistPanel(
tabPanel("Dynamic Dimensions",
myPlotUI("myPlot"))
)
)
shinyApp(ui = ui, server = server)
Related
I am trying to include LateX formulas inside a table and I am using the MathJack library to do so. Everthing is working smoothly outside a modalDialog, but when the table is produced within the modalDialog, it does not show as expected. I guess it has do to with what is written in the help page "It only needs to be called once in an app unless the content is rendered after the page is loaded, e.g. via renderUI(), in which case we have to call it explicitly every time we write math expressions to the output.". But I can't figure out how to solve the issue.
Here is a repex :
library(shiny)
ui <- shinyUI(
fluidPage(
withMathJax(),
actionButton("open", "Open")))
server <- function(input, output, session){
output$mytable <- renderTable({
df <- data.frame(A = c(HTML("$$\\alpha+\\beta$$"), "$$\\alpha+\\gamma$$", "$$\\alpha+\\lambda$$"),B = c(111111, 3333333, 3123.233))
df
}, sanitize.text.function = function(x) x)
observeEvent(input$open, {
showModal(modalDialog(
withMathJax(),
h2("$$\\mbox{My Math example }\\sqrt{2}$$"),
tableOutput('mytable')))
})
}
shinyApp(ui = ui, server = server)
Oddly, that works like this:
observeEvent(input$open, {
showModal(withMathJax(modalDialog(
h2("$$\\mbox{My Math example }\\sqrt{2}$$"),
withMathJax(tableOutput('mytable')))))
})
EDIT
Since there are some problems with this solution, here is a solution using KaTeX instead of MathJax:
library(shiny)
js <- "
$(document).on('shiny:value', function(event) {
if(event.name === 'mytable'){
// h2 element
var $h2 = $('#title');
var title = $h2.html();
var matches_title = title.match(/(%%+[^%]+%%)/g);
var i, code;
for(i=0; i<matches_title.length; i++){
code = matches_title[i].slice(2,-2);
title = title.replace(matches_title[i], katex.renderToString(code));
}
$h2.html(title);
$h2.css('visibility', 'visible');
// table:
var matches = event.value.match(/(%%+[^%]+%%)/g);
var newvalue = event.value;
for(i=0; i<matches.length; i++){
code = matches[i].slice(2,-2);
newvalue = newvalue.replace(matches[i], katex.renderToString(code));
}
event.value = newvalue;
}
})
"
css <- "#mytable td:nth-child(3) {display: none;}"
ui <- fluidPage(
tags$head(
tags$link(rel="stylesheet", href="https://cdn.jsdelivr.net/npm/katex#0.15.2/dist/katex.min.css", integrity="sha384-MlJdn/WNKDGXveldHDdyRP1R4CTHr3FeuDNfhsLPYrq2t0UBkUdK2jyTnXPEK1NQ", crossorigin="anonymous"),
tags$script(defer="", src="https://cdn.jsdelivr.net/npm/katex#0.15.2/dist/katex.min.js", integrity="sha384-VQ8d8WVFw0yHhCk5E8I86oOhv48xLpnDZx5T9GogA/Y84DcCKWXDmSDfn13bzFZY", crossorigin="anonymous"),
tags$script(HTML(js)),
tags$style(HTML(css))
),
titlePanel("Hello Shiny!"),
br(),
actionButton("open", "Open")
)
server <- function(input, output, session){
output$mytable <- renderTable({
data.frame(
A = c("%%\\alpha+\\beta%%", "%%\\alpha+\\gamma%%", "%%\\alpha+\\lambda%%"),
B = c(111111, 3333333, 3123.233),
` ` = rep(input$open, 3),
check.names = FALSE
)
}, sanitize.text.function = function(x) x)
observeEvent(input$open, {
showModal(modalDialog(
h2(
id = "title",
style = "visibility: hidden;",
"%%\\boxed{Math}\\sqrt{2}%%"
),
tableOutput("mytable")
))
})
}
shinyApp(ui, server)
Note that I include a reactive column in the dataframe:
` ` = rep(input$open, 3)
That's because the KaTeX rendering works only one time if I don't do that. Then I hide this column with some CSS.
I have used panzoom package in order to pan and zoom on my svg file in my shiny app. Is there a way to have controls like this?
library(shiny)
library(DiagrammeR)
library(magrittr)
ui <- fluidPage(
tags$head(
tags$script(src = "https://unpkg.com/panzoom#9.4.0/dist/panzoom.min.js")
),
grVizOutput("grr", width = "100%", height = "90vh"),
tags$script(
HTML('panzoom($("#grr")[0])')
)
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3)))
})
output$grr <- renderGrViz(reactives$graph)
}
shinyApp(ui, server)
Here is a way, but if you click too quickly on the +/- buttons, there's an undesirable effect.
library(shiny)
library(shinyWidgets)
library(DiagrammeR)
library(magrittr)
js <- '
$(document).ready(function(){
var element = document.getElementById("grr");
var instance = panzoom(element);
$("#zoomout").on("click", function(){
instance.smoothZoom(0, 0, 0.9);
});
$("#zoomin").on("click", function(){
instance.smoothZoom(0, 0, 1.1);
});
});
'
ui <- fluidPage(
tags$head(
tags$script(src = "https://unpkg.com/panzoom#9.4.0/dist/panzoom.min.js"),
tags$script(HTML(js))
),
grVizOutput("grr", width = "100%", height = "90vh"),
actionGroupButtons(
inputIds = c("zoomout", "zoomin"),
labels = list(icon("minus"), icon("plus")),
status = "primary"
)
)
server <- function(input, output) {
reactives <- reactiveValues()
observe({
reactives$graph <- render_graph(
create_graph() %>%
add_n_nodes(n = 2) %>%
add_edge(
from = 1,
to = 2,
edge_data = edge_data(
value = 4.3
)
)
)
})
output$grr <- renderGrViz(reactives$graph)
}
shinyApp(ui, server)
EDIT
Add this JavaScript to prevent the undesirable effect:
$("#zoomout").on("dblclick", function(){
return false;
});
$("#zoomin").on("dblclick", function(){
return false;
});
Below is a shiny app which displays a slideshow of images with the slickR package. How to get the name of the current image?
library(shiny)
library(slickR)
ui <- fluidPage(
tags$div(
slickROutput("slickr", width="500px"),
style = "margin-left:100px;"
)
)
server <- function(input, output) {
imgs <- list.files("~/", pattern=".png", full.names = TRUE)
output[["slickr"]] <- renderSlickR({
slickR(imgs)
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here is a solution with a MutationObserver:
library(shiny)
library(slickR)
js <- "
$(document).ready(function(){
var ss = document.getElementById('slickr');
// create an observer instance
var observer = new MutationObserver(function(mutations) {
var index = $(ss).find('.slick-current').data('slick-index');
Shiny.setInputValue('imageIndex', parseInt(index)+1);
});
// configuration of the observer
var config = {subtree: true, attributes: true};
// observe
observer.observe(ss, config);
})
"
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
textOutput("imgName"),
tags$hr(),
tags$div(
slickROutput("slickr", width="500px"),
style = "margin-left:100px;"
)
)
server <- function(input, output) {
imgs <- list.files("~/", pattern=".png", full.names = TRUE)
output[["slickr"]] <- renderSlickR({
slickR(imgs)
})
output[["imgName"]] <- renderText({
paste0("CURRENT IMAGE: ", basename(imgs[input[["imageIndex"]]]))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Another solution, simpler: replace js with
js <- "
$(document).ready(function(){
$('#slickr').on('setPosition', function(event, slick) {
var index = slick.currentSlide + 1;
Shiny.setInputValue('imageIndex', index);
});
})"
Maybe something like this workaround?
I am using the index of the image and get the basename of the imagelist.
library(shiny)
library(slickR)
jscode <- HTML("
$(document).on('shiny:connected', function(event) {
var imagindex = 0;
Shiny.onInputChange('slickin', imagindex);
$(document).on('click', '.slick-arrow', function(event) {
var imagindex = $('.slick-active')[0].attributes[1].value;
Shiny.onInputChange('slickin', imagindex);
});
$(document).on('click', '.slick-dots', function(event) {
var imagindex = $('.slick-active')[0].attributes[1].value;
Shiny.onInputChange('slickin', imagindex);
});
});
")
ui <- fluidPage(
tags$head(tags$script(jscode)),
tags$div(
slickROutput("slickr", width="500px"),
style = "margin-left:100px;"
)
)
server <- function(input, output) {
imgs <- list.files(getwd(), pattern=".png", full.names = TRUE);
output[["slickr"]] <- renderSlickR({
slickR(imgs)
})
observe( {
req(input$slickin)
print(basename(imgs[as.numeric(input$slickin) + 1]))
})
}
shinyApp(ui = ui, server = server)
The slickR shiny vignette describes the "official" way without using custom JS:
Observe the active slick
The htmlwidget is observed by shiny and information can be retrieved.
Using the output name you set for the renderSlick object in this example
it is output$slick_output
Using this you can interact server-side "on click" of the active carousel
by accessing elements in input$slick_output_current$
.clicked : The index of the clicked element
.relative_clicked: The relative position of the clicked element
.center : The index of the center element
.total : The total number of elements in the carousel
.active : The ID of the active carousel
library(shiny)
library(slickR)
# create some local images
if(!dir.exists("myimages")){
dir.create("myimages")
}
imgs <- paste0("myimages/myplot", seq_len(3), ".png")
for (myPlot in myPlots) {
png(file = myPlot, bg = "transparent")
plot(runif(10))
dev.off()
}
ui <- fluidPage(
tags$head(
tags$script(HTML(js))
),
textOutput("imgName"),
tags$hr(),
tags$div(
slickROutput("slickr", width="500px"),
style = "margin-left:100px;"
)
)
server <- function(input, output) {
output[["slickr"]] <- renderSlickR({
slickR(imgs)
})
output[["imgName"]] <- renderText({
paste0("CURRENT IMAGE: ", basename(imgs[input$slickr_current$.center]))
})
}
# Run the application
shinyApp(ui = ui, server = server)
Here's a solution from one of the slickR vignettes:
slickR(obj = nba_player_logo$uri[1:2], height = 100, width = "95%") %synch%
( slickR(nba_player_logo$name[1:2], slideType = 'p') + settings(arrows = FALSE) )
Worked great for me.
i got stuck at some point while trying to use downloadHandler to download Plotly images. I just cannot figure out further how to get the image from temp directory...
Here is a sample code:
library(shiny)
library(plotly)
library(rsvg)
library(ggplot2)
d <- data.frame(X1=rnorm(50,mean=50,sd=10),X2=rnorm(50,mean=5,sd=1.5),Y=rnorm(50,mean=200,sd=25))
ui <-fluidPage(
title = 'Download Plotly',
sidebarLayout(
sidebarPanel(
helpText(),
downloadButton('download'),
tags$script('
document.getElementById("download").onclick = function() {
var plotly_svg = Plotly.Snapshot.toSVG(
document.querySelectorAll(".plotly")[0]
);
Shiny.onInputChange("plotly_svg", plotly_svg);
};
')
),
mainPanel(
plotlyOutput('regPlot'),
plotlyOutput('regPlot2')
)
)
)
server <- function(input, output, session) {
output$regPlot <- renderPlotly({
p <- plot_ly(d, x = d$X1, y = d$X2,mode = "markers")
p
})
output$regPlot2 <- renderPlotly({
p <- plot_ly(d, x = d$X1, y = d$X2,mode = "markers")
p
})
observeEvent(input$plotly_svg, priority = 10, {
png_gadget <- tempfile(fileext = ".png")
png_gadget <- "out.png"
print(png_gadget)
rsvg_png(charToRaw(input$plotly_svg), png_gadget)
})
output$download <- downloadHandler(
filename = function(){
paste(paste("test",Sys.Date(),sep=""), ".png",sep="")},
content = function(file) {
temp_dir <- tempdir()
tempImage <- file.path(temp_dir, 'out.png')
file.copy('out.png', tempImage, overwrite = TRUE)
png(file, width = 1200, height = 800, units = "px", pointsize = 12, bg = "white", res = NA)
dev.off()
})
}
shinyApp(ui = ui, server = server)
Additionally i am not sure how can i choose which of the plotly images should be downloaded. Thanks for any tips and help!
Info:
--> I have tried using webshot, however if I zoom or filter in any way plot, unfortunatelly webshot does not mirror it
--> i am not using the available plotly panel for download, because it is not working using IE
The OP has edited his/her post to add a requirement:
--> I have tried using webshot, however if I zoom or filter in any way plot, unfortunatelly webshot does not mirror it
Below is a Javascript solution, which doesn't need additional libraries. I'm not fluent in Javascript and I'm not sure the method is the most direct one: I'm under the impression that this method creates a file object from a url and then it creates a url from the file object. I will try to minimize the code.
library(shiny)
library(plotly)
d <- data.frame(X1 = rnorm(50,mean=50,sd=10),
X2 = rnorm(50,mean=5,sd=1.5),
Y = rnorm(50,mean=200,sd=25))
ui <-fluidPage(
title = 'Download Plotly',
sidebarLayout(
sidebarPanel(
helpText(),
actionButton('download', "Download")
),
mainPanel(
plotlyOutput('regPlot'),
plotlyOutput('regPlot2'),
tags$script('
function download(url, filename, mimeType){
return (fetch(url)
.then(function(res){return res.arrayBuffer();})
.then(function(buf){return new File([buf], filename, {type:mimeType});})
);
}
document.getElementById("download").onclick = function() {
var gd = document.getElementById("regPlot");
Plotly.Snapshot.toImage(gd, {format: "png"}).once("success", function(url) {
download(url, "plot.png", "image/png")
.then(function(file){
var a = window.document.createElement("a");
a.href = window.URL.createObjectURL(new Blob([file], {type: "image/png"}));
a.download = "plot.png";
document.body.appendChild(a);
a.click();
document.body.removeChild(a);
});
});
}
')
)
)
)
server <- function(input, output, session) {
regPlot <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot <- renderPlotly({
regPlot()
})
regPlot2 <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot2 <- renderPlotly({
regPlot2()
})
}
shinyApp(ui = ui, server = server)
EDIT
I was right. There's a shorter and cleaner solution:
tags$script('
document.getElementById("download").onclick = function() {
var gd = document.getElementById("regPlot");
Plotly.Snapshot.toImage(gd, {format: "png"}).once("success", function(url) {
var a = window.document.createElement("a");
a.href = url;
a.type = "image/png";
a.download = "plot.png";
document.body.appendChild(a);
a.click();
document.body.removeChild(a);
});
}
')
EDIT
To select the plot to download, you can do:
sidebarLayout(
sidebarPanel(
helpText(),
selectInput("selectplot", "Select plot to download", choices=list("plot1","plot2")),
actionButton('download', "Download")
),
mainPanel(
plotlyOutput('regPlot'),
plotlyOutput('regPlot2'),
tags$script('
document.getElementById("download").onclick = function() {
var plot = $("#selectplot").val();
if(plot == "plot1"){
var gd = document.getElementById("regPlot");
}else{
var gd = document.getElementById("regPlot2");
}
Plotly.Snapshot.toImage(gd, {format: "png"}).once("success", function(url) {
var a = window.document.createElement("a");
a.href = url;
a.type = "image/png";
a.download = "plot.png";
document.body.appendChild(a);
a.click();
document.body.removeChild(a);
});
}
')
)
)
1) Install the webshot package.
2) Install phantom.js:
library(webshot)
install_phantomjs()
See ?install_phantomjs for the details.
3) Now you can use the export function of the plotly package:
library(shiny)
library(plotly)
d <- data.frame(X1 = rnorm(50,mean=50,sd=10),
X2 = rnorm(50,mean=5,sd=1.5),
Y = rnorm(50,mean=200,sd=25))
ui <-fluidPage(
title = 'Download Plotly',
sidebarLayout(
sidebarPanel(
helpText(),
downloadButton('download')
),
mainPanel(
plotlyOutput('regPlot'),
plotlyOutput('regPlot2')
)
)
)
server <- function(input, output, session) {
regPlot <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot <- renderPlotly({
regPlot()
})
regPlot2 <- reactive({
plot_ly(d, x = d$X1, y = d$X2, mode = "markers")
})
output$regPlot2 <- renderPlotly({
regPlot2()
})
output$download <- downloadHandler(
filename = function(){
paste0(paste0("test", Sys.Date()), ".png")
},
content = function(file) {
export(regPlot(), file=file)
})
}
shinyApp(ui = ui, server = server)
You can save to the svg format. See ?export for the explanations.
Instead of using webshot, you should consider to try webshot2. See my detailed answer to the similar case.
# Webshot and phantomjs have been previously installed.
library(webshot2)
I would like to have the shiny-plotly output height and width adjusted to the current window size. I have tried to use the below but of no use.
ShinyUi <- fluidPage(
# Application title
titlePanel("title"),
sidebarLayout(
sidebarPanel(
... inputs ...
),
mainPanel(
plotlyOutput("distPlot", height = 'auto', width = 'auto')
)
))
ShinyServer <- function(input, output, session) {
output$distPlot <- renderPlotly({
p <- ggplot(dataShow, aes(x=dataShow$X, y=dataShow$Y)) +
geom_point(shape=1, alpha = 0.5, color = "grey50")
ggplotly(p)
})
}
# Run the application
shinyApp(ui = ShinyUi, server = ShinyServer)
Would you know of any other options to use maybe in server function instead of the above UI function usage?
Smaller Window:
Expanded Window:
It does not answer your question but in line to my comments you can add the plot height and width to the ggplotly function using the js from this link.
I have prepared a minimal example of what you are want.
library(shiny)
library(plotly)
ShinyUi <- fluidPage(
tags$head(tags$script('
var dimension = [0, 0];
$(document).on("shiny:connected", function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
});
$(window).resize(function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
});
')),
plotlyOutput("distPlot", width = "auto")
)
ShinyServer <- function(input, output, session) {
#To make the responsive to the change in UI size
observeEvent(input$dimension,{
output$distPlot <- renderPlotly({
p <- ggplot(iris, aes(x = Sepal.Length, y=Sepal.Width)) +
geom_point(shape=1, alpha = 0.5, color = "grey50")
ggplotly(p, width = (0.95*as.numeric(input$dimension[1])), height = as.numeric(input$dimension[2]))
})
})
}
# Run the application
shinyApp(ui = ShinyUi, server = ShinyServer)
The output you get is as follows:
Now when you make the window even smaller you still get a plot which occupies the whole screen (no scrollbars!) as follows:
Foreward
Please see the post by #SBista first.
I simply want to add to that response for a special use case: to lower the frequency of times Shiny attempts to re-render a visualization as the window is slowly resized by grabbing one of the edges of the window with the mouse and resizing that way. For me, render time took awhile, and without this additional code, it was doing several re-renders back to back from just one window resize.
Answer
Inside my ui.R I have a tags$script with the following JS string:
console.log("INFO: Loaded ui.R custom JS.");
// VARS
const REFRESH_RATE_MIN_SECONDS = 1.5;
var dimension = [0, 0];
var notRecentlyRendered = true;
var midRender = false;
var timeNow = Date.now();
var lastRendered;
var nowDiffMs;
// METHODS
$(document).on("shiny:connected", function(e) {
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
Shiny.onInputChange("dimension", dimension);
})
$(window).resize(function(e) {
timeNow = Date.now();
firstRender = (typeof(lastRendered) === "undefined");
if (firstRender === true) {
nowDiffMs = timeNow - lastRendered;
refreshRateMinMs = REFRESH_RATE_MIN_SECONDS * 1000;
notRecentlyRendered = nowDiffMs > refreshRateMinMs;
}
if ((midRender === false) && (notRecentlyRendered === true)) {
console.log("INFO: Adjusting figure height.");
dimension[0] = window.innerWidth;
dimension[1] = window.innerHeight;
midRender = true;
Shiny.onInputChange("dimension", dimension);
}
})
In my server.R file I have my observable:
observeEvent(input$dimension,{
output$multi_indicator_facility <- renderPlotly({
plot.multi_indicator_facility(input)
})
In another file where I have plot.multi_indicator_facility(), which goes roughly as follows:
gg = ggplot(...) # ... = a lot of code
ggp = ggplotly(gg, height=figure.height) # I took figure.height from input$dimension
# More JS within R:
ggp = onRender(
ggp, '
function(el) {
console.log("Rendered.");
lastRendered = Date.now();
midRender = false;
}
')
return(ggp)
Also don't forget to include the htmlwidgets lib to use onRender.
library('htmlwidgets') # <-- include this somewhere (e.g. server.R)