chartJSRadar downloadhandler creating empty png - r

I would like to create a download button within my shiny app to download a reactive plot created with chartJSRadar. I am not able to solve this problem!
As I have been through the documented problem on the internet, I was not able to solve it, receiving all the time an empty png. As suggested (Save plots made in a shiny app), https://groups.google.com/forum/#!msg/shiny-discuss/u7gwXc8_vyY/IZK_o7b7I8gJ
I built a function ...
So my code is an example code:
ui.R:
library(radarchart)
shinyUI(pageWithSidebar(
headerPanel('Radarchart Shiny Example'),
sidebarPanel(
checkboxGroupInput('selectedPeople', 'Who to include',
names(radarchart::skills)[-1], selected="Rich")
),
mainPanel(
chartJSRadarOutput("plot1", width = "450", height = "300"), width = 7,
radioButtons(inputId = "var3", label = "Select the file type", choices = list("png", "pdf")),
downloadButton('downloadPlot', 'Download Plot')
)
))
server.R
library(radarchart)
shinyServer(function(input, output) {
output$plot1 <- renderChartJSRadar({
chartJSRadar(skills[, c("Label", input$selectedPeople)],
maxScale = 10, showToolTipLabel=TRUE)
})
plot2 <- function(){
chartJSRadar(skills[, c("Label", input$selectedPeople)],
maxScale = 10, showToolTipLabel=TRUE)
}
output$downloadPlot <- downloadHandler(
filename = "Shinyplot.png",
content = function(file) {
png(file)
plot2()
print(plot2())
dev.off()
})
})

Here is a JavaScript way which should be faster than webshot, I think.
library(shiny)
library(radarchart)
library(htmlwidgets) # to use the 'onRender' function
js <- c(
"function(el, x){",
" $('#downloadPlot').on('click', function(){",
" // Clone the chart to add a background color.",
" var cloneCanvas = document.createElement('canvas');",
" cloneCanvas.width = el.width;",
" cloneCanvas.height = el.height;",
" var ctx = cloneCanvas.getContext('2d');",
" ctx.fillStyle = '#FFFFFF';",
" ctx.fillRect(0, 0, el.width, el.height);",
" ctx.drawImage(el, 0, 0);",
" // Download.",
" const a = document.createElement('a');",
" document.body.append(a);",
" a.download = 'radarchart.png';",
" a.href = cloneCanvas.toDataURL('image/png');",
" a.click();",
" a.remove();",
" });",
"}"
)
ui <- pageWithSidebar(
headerPanel('Radarchart Shiny Example'),
sidebarPanel(
checkboxGroupInput('selectedPeople', 'Who to include',
names(radarchart::skills)[-1], selected="Rich"),
actionButton('downloadPlot', 'Download Plot')
),
mainPanel(
chartJSRadarOutput("plot1", width = "450", height = "300"), width = 7
)
)
server <- function(input, output) {
output$plot1 <- renderChartJSRadar({
chartJSRadar(skills[, c("Label", input$selectedPeople)],
maxScale = 10, showToolTipLabel=TRUE) %>%
onRender(js)
})
}
shinyApp(ui, server)
This exports to png only. Use webshot to export to pdf.
EDIT
library(shiny)
library(radarchart)
js <- paste0(c(
"$(document).ready(function(){",
" $('#downloadPlot').on('click', function(){",
" var el = document.getElementById('plot1');",
" // Clone the chart to add a background color.",
" var cloneCanvas = document.createElement('canvas');",
" cloneCanvas.width = el.width;",
" cloneCanvas.height = el.height;",
" var ctx = cloneCanvas.getContext('2d');",
" ctx.fillStyle = '#FFFFFF';",
" ctx.fillRect(0, 0, el.width, el.height);",
" ctx.drawImage(el, 0, 0);",
" // Download.",
" const a = document.createElement('a');",
" document.body.append(a);",
" a.download = 'radarchart.png';",
" a.href = cloneCanvas.toDataURL('image/png');",
" a.click();",
" a.remove();",
" cloneCanvas.remove();",
" });",
"});"
), collapse = "\n")
ui <- pageWithSidebar(
headerPanel('Radarchart Shiny Example'),
sidebarPanel(
checkboxGroupInput('selectedPeople', 'Who to include',
names(radarchart::skills)[-1], selected="Rich"),
actionButton('downloadPlot', 'Download Plot')
),
mainPanel(
tags$head(tags$script(HTML(js))),
chartJSRadarOutput("plot1", width = "450", height = "300"), width = 7
)
)
server <- function(input, output) {
output$plot1 <- renderChartJSRadar({
chartJSRadar(skills[, c("Label", input$selectedPeople)],
maxScale = 10, showToolTipLabel=TRUE)
})
}
shinyApp(ui, server)

chartJSRadar returns an htmlWidget. To save, try using saveWidget and then webshot of the temporary html file. Add webshot library:
library(webshot)
and try substituting this for downloadHandler in your server function:
output$downloadPlot <- downloadHandler(
filename = "Shinyplot.png",
content = function(file) {
saveWidget(plot2(), "temp.html", selfcontained = TRUE)
webshot("temp.html", file = file)
}
)

Related

Make a nicer looking dropdown filter label with DataTables DT in R

I'm trying to make a datatable for a shiny dashboard that will have a dropdown filter on a column. I actually have it working, but the appearance is what I'd call subpar.
Here is my simple example
library(DT)
mytable <- data.frame(Col1 = as.factor(LETTERS[1:3]))
datatable(mytable, filter = "top")
When I have the dropdown active, the filter text input looks nice:
However, when I click away, it does not look as nice:
Is there any way to keep that nice looking A with an x in a bubble (sorry I'm sure there's a better term for that), or at least get rid of the bracket and quotation marks? I know that if the column values are characters rather than factors, I can get a nicer looking text input, but them I lose the dropdown functionality (related to this question Factor dropdown filter in DT::datatable in shiny dashboards not working), which I need.
mytable <- data.frame(Col1 = LETTERS[1:3], stringsAsFactors = FALSE)
datatable(mytable, filter = "top")
I'd be happy with a cell dropdown like the one in this post Edit datatable in Shiny with dropdown selection for factor variables, but I need to filter the table, not edit it.
Version info:
R version 3.5.3
DT_0.20
I know how to do that but with the dropdowns in the footer, I don't know how to put them at the top. The code uses the JavaScript library select2.
library(shiny)
library(DT)
dat <- iris
sketch <- htmltools::tags$table(
tableHeader(c("",names(dat))),
tableFooter(rep("", 1+ncol(dat)))
)
js <- c(
"function(){",
" this.api().columns().every(function(i){",
" var column = this;",
" var select = $('<select multiple=\"multiple\"><option value=\"\"></option></select>')",
" .appendTo( $(column.footer()).empty() )",
" .on('change', function(){",
" var vals = $('option:selected', this).map(function(index,element){",
" return $.fn.dataTable.util.escapeRegex($(element).val());",
" }).toArray().join('|');",
" column.search(vals.length > 0 ? '^('+vals+')$' : '', true, false).draw();",
" });",
" var data = column.data();",
" if(i == 0){",
" data.each(function(d, j){",
" select.append('<option value=\"'+d+'\">'+d+'</option>');",
" });",
" }else{",
" data.unique().sort().each(function(d, j){",
" select.append('<option value=\"'+d+'\">'+d+'</option>');",
" });",
" }",
" select.select2({width: '100%', closeOnSelect: false});",
" });",
"}")
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js")
),
br(),
DTOutput("dtable")
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(
dat, container=sketch,
options = list(
initComplete = JS(js),
columnDefs = list(
list(targets = "_all", className = "dt-center")
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)
Edit
To have the filters at the top:
library(shiny)
library(DT)
library(htmltools)
dat <- iris
sketch <- tags$table(
tags$thead(
tags$tr(
tags$th(),
lapply(names(dat), tags$th)
),
tags$tr(
tags$th(id = "th0"),
tags$th(id = "th1"),
tags$th(id = "th2"),
tags$th(id = "th3"),
tags$th(id = "th4"),
tags$th(id = "th5")
)
)
)
js <- c(
"function(){",
" this.api().columns().every(function(i){",
" var column = this;",
" var select = $('<select multiple=\"multiple\"><option value=\"\"></option></select>')",
" .appendTo( $('#th'+i).empty() )",
" .on('change', function(){",
" var vals = $('option:selected', this).map(function(index,element){",
" return $.fn.dataTable.util.escapeRegex($(element).val());",
" }).toArray().join('|');",
" column.search(vals.length > 0 ? '^('+vals+')$' : '', true, false).draw();",
" });",
" var data = column.data();",
" if(i == 0){",
" data.each(function(d, j){",
" select.append('<option value=\"'+d+'\">'+d+'</option>');",
" });",
" }else{",
" data.unique().sort().each(function(d, j){",
" select.append('<option value=\"'+d+'\">'+d+'</option>');",
" });",
" }",
" select.select2({width: '100%', closeOnSelect: false});",
" });",
"}")
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/css/select2.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/select2/4.0.13/js/select2.min.js")
),
br(),
DTOutput("dtable")
)
server <- function(input, output, session){
output[["dtable"]] <- renderDT({
datatable(
dat, container=sketch,
options = list(
orderCellsTop = TRUE,
initComplete = JS(js),
columnDefs = list(
list(targets = "_all", className = "dt-center")
)
)
)
}, server = FALSE)
}
shinyApp(ui, server)

R DT Shiny KeyTable select cell/row with Enter

In R, the DT KeyTable extension allows to move around the cells with arrow keys.
Is it possible to select the current cell with Enter instead of a mouse click?
Thank you in advance.
library(shiny)
library(DT)
library(datasets)
df <- datasets::mtcars
# Define UI for application that draws a histogram
ui <- fluidPage(
DTOutput('table'), HTML("<br>"),
textOutput('selected')
)
# Define server logic required to draw a histogram
server <- function(input, output) {
output$table <- renderDT(
df,
selection = 'single',
extensions = 'KeyTable',
options = list(
dom = 't',
keys = TRUE
)
)
output$selected <- renderText({
print(rownames(df)[input$table_rows_selected])
})
}
# Run the application
shinyApp(ui = ui, server = server)
To select cells:
library(shiny)
library(DT)
js <- c(
"table.on('key', function(e, datatable, key, cell, originalEvent){",
" if(key == 13){",
" cell.select();",
" }",
"});"
)
ui <- fluidPage(
DTOutput('table'),
br(),
verbatimTextOutput('selected')
)
server <- function(input, output) {
output$table <- renderDT(
iris,
selection = 'none',
extensions = c("KeyTable", "Select"),
callback = JS(js),
options = list(
dom = 't',
keys = TRUE,
select = list(style = "multi", items = "cell")
),
server = FALSE
)
output$selected <- renderPrint({
input$table_cells_selected
})
}
# Run the application
shinyApp(ui = ui, server = server)
If you also want to deselect:
js <- c(
"table.on('key', function(e, dt, key, cell, originalEvent){",
" if(key == 13){",
" var selected = dt.cells({selected: true});",
" var indices = selected.indexes().toArray().map(JSON.stringify);",
" if(indices.indexOf(JSON.stringify(cell.index())) === -1) {",
" cell.select();",
" } else {",
" cell.deselect();",
" }",
" }",
"});"
)

Animating static images in Shiny

I'm building a Shiny app that displays various pre-rendered .png and .svg images across multiple tabs, with some of the images being chosen through different types of input. To add some pizzazz, I'd like to add animations to the images that play whenever an image is displayed, either when the tab that it's on is selected or when it is chosen through an input.
I've tried using shinyjs::show/hide and shinyjqui::jqui_effect, but those functions seem to want to respond to some input, like a button press, rather than playing automatically and repeatedly.
I've managed to put together the code below that uses shinyanimate to achieve the desired effect. However, my real app has many more tabs and images, and this method of having every animation react to any changes in the tabs or inputs seems inefficient. Is there a better way of doing this?
(N.B. I'm only using the "bounceInLeft" effect here because it makes the example clear, but I'd like to be able to use other animation effects such as "fadeIn").
library(shiny)
library(shinyanimate)
# Define UI
ui <- fluidPage(
withAnim(),
tabsetPanel(id = "tabs",
# Tab 1 ----
tabPanel("Tab 1",
fluidRow(
column(3,
imageOutput("tab1_img1")
),
column(3,
imageOutput("tab1_img2")
)
)
),
# Tab 2 ----
tabPanel("Tab 2",
selectInput("img_opts",
label = "Select image",
choices = c("img2", "img1")
),
imageOutput("tab2_imgs")
)
)
)
# Define server logic
server <- function(input, output) {
# Tab 1 image 1
output$tab1_img1 <- renderImage({
list(src = file.path("images/img1.png"), width = "95%")
}, deleteFile = FALSE)
# Tab 1 image 1 animation
observeEvent(input$tabs,
startAnim(session = getDefaultReactiveDomain(), "tab1_img1", "bounceInLeft")
)
# Tab 1 image 2
output$tab1_img2 <- renderImage({
list(src = file.path("images/img2.png"), width = "95%")
}, deleteFile = FALSE)
# Tab 1 image 2 animation
observeEvent(input$tabs,
startAnim(session = getDefaultReactiveDomain(), "tab1_img2", "bounceInLeft")
)
# Tab 2 images
output$tab2_imgs <- renderImage({
list(src = file.path(paste0("images/", input$img_opts, ".png")), width = "25%")
}, deleteFile = FALSE)
# Tab 2 animation
observeEvent(c(input$tabs, input$img_opts),
startAnim(session = getDefaultReactiveDomain(), "tab2_imgs", "bounceInLeft")
)
}
# Run the application
shinyApp(ui = ui, server = server)
You can achieve the same result with only one observer:
tabsetPanel(id = "tabs",
# Tab 1 ----
tabPanel("Tab 1",
imageOutput("tab1_img"),
value = "tab1_img"
),
# Tab 2 ----
tabPanel("Tab 2",
selectInput("img_opts",
label = "Select image",
choices = c("img2", "img1")
),
imageOutput("tab2_img"),
value = "tab2_img"
)
)
observeEvent(c(input$tabs, input$img_opts), {
startAnim(session = getDefaultReactiveDomain(), input$tabs, "bounceInLeft")
})
EDIT: using shinyjqui
library(shiny)
library(shinyjqui)
ui <- fluidPage(
tabsetPanel(
id = "tabs",
# Tab 1 ----
tabPanel(
"Tab 1",
fluidRow(
column(3,
imageOutput("tab1_img1")
),
column(3,
imageOutput("tab1_img2")
)
)
),
# Tab 2 ----
tabPanel(
"Tab 2",
selectInput("img_opts",
label = "Select image",
choices = c("img3", "img4")
),
imageOutput("tab2_imgs")
)
)
)
server <- function(input, output, session) {
# Tab 1 image 1
output$tab1_img1 <- renderImage({
list(src = "www/img1.JPG", width = "300")
}, deleteFile = FALSE)
# Tab 1 image 2
output$tab1_img2 <- renderImage({
list(src = "www/img2.JPG", width = "300")
}, deleteFile = FALSE)
# Tab 2 images
output$tab2_imgs <- renderImage({
list(src = paste0("www/", input$img_opts, ".JPG"), width = "300")
}, deleteFile = FALSE)
# animate
observeEvent(list(input$tabs, input$img_opts), {
jqui_effect(
paste0("div.tab-pane[data-value=\"", input$tabs, "\"] img"),
"shake",
options = list(direction = "right", distance = 50, times = 3),
duration = 1500
)
}, ignoreInit = FALSE)
}
shinyApp(ui = ui, server = server)
EDIT: better solution
Here is a solution using the JavaScript library jquery.animatecss and the CSS library animate.css, which is the library used by shinyanimate. The app below requires an internet connection to include these libraries (see tags$head); it's better to download them (and then to put them in the www subfolder).
library(shiny)
js <- HTML(
'$(document).on("shiny:connected", function() {',
' Shiny.addCustomMessageHandler("animate", function(tab) {',
' var $tab = $("div.tab-pane[data-value=\\\"" + tab + "\\\"]");',
' var $imgs = $tab.find(".shiny-image-output");',
' $imgs.animateCSS("bounceInLeft", {duration: 1500});',
' });',
'});'
)
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/animate.css/4.1.0/animate.compat.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/animateCSS/1.2.2/jquery.animatecss.min.js"),
tags$script(js)
),
tabsetPanel(
id = "tabs",
# Tab 1 ----
tabPanel(
"Tab 1",
fluidRow(
column(3,
imageOutput("tab1_img1")
),
column(3,
imageOutput("tab1_img2")
)
)
),
# Tab 2 ----
tabPanel(
"Tab 2",
selectInput("img_opts",
label = "Select image",
choices = c("img3", "img4")
),
imageOutput("tab2_imgs")
)
)
)
server <- function(input, output, session) {
# Tab 1 image 1
output$tab1_img1 <- renderImage({
list(src = "www/img1.JPG", width = "300")
}, deleteFile = FALSE)
# Tab 1 image 2
output$tab1_img2 <- renderImage({
list(src = "www/img2.JPG", width = "300")
}, deleteFile = FALSE)
# Tab 2 images
output$tab2_imgs <- renderImage({
list(src = paste0("www/", input$img_opts, ".JPG"), width = "300")
}, deleteFile = FALSE)
# animate
observeEvent(list(input$tabs, input$img_opts), {
session$sendCustomMessage("animate", input$tabs)
}, ignoreInit = FALSE)
}
# Run the application
shinyApp(ui = ui, server = server)
Here is the list of available effects:
c(
"bounce",
"flash",
"pulse",
"rubberBand",
"shakeX",
"shakeY",
"headShake",
"swing",
"tada",
"wobble",
"jello",
"heartBeat",
"backInDown",
"backInLeft",
"backInRight",
"backInUp",
"backOutDown",
"backOutLeft",
"backOutRight",
"backOutUp",
"bounceIn",
"bounceInDown",
"bounceInLeft",
"bounceInRight",
"bounceInUp",
"bounceOut",
"bounceOutDown",
"bounceOutLeft",
"bounceOutRight",
"bounceOutUp",
"fadeIn",
"fadeInDown",
"fadeInDownBig",
"fadeInLeft",
"fadeInLeftBig",
"fadeInRight",
"fadeInRightBig",
"fadeInUp",
"fadeInUpBig",
"fadeInTopLeft",
"fadeInTopRight",
"fadeInBottomLeft",
"fadeInBottomRight",
"fadeOut",
"fadeOutDown",
"fadeOutDownBig",
"fadeOutLeft",
"fadeOutLeftBig",
"fadeOutRight",
"fadeOutRightBig",
"fadeOutUp",
"fadeOutUpBig",
"fadeOutTopLeft",
"fadeOutTopRight",
"fadeOutBottomRight",
"fadeOutBottomLeft",
"flip",
"flipInX",
"flipInY",
"flipOutX",
"flipOutY",
"lightSpeedInRight",
"lightSpeedInLeft",
"lightSpeedOutRight",
"lightSpeedOutLeft",
"rotateIn",
"rotateInDownLeft",
"rotateInDownRight",
"rotateInUpLeft",
"rotateInUpRight",
"rotateOut",
"rotateOutDownLeft",
"rotateOutDownRight",
"rotateOutUpLeft",
"rotateOutUpRight",
"hinge",
"jackInTheBox",
"rollIn",
"rollOut",
"zoomIn",
"zoomInDown",
"zoomInLeft",
"zoomInRight",
"zoomInUp",
"zoomOut",
"zoomOutDown",
"zoomOutLeft",
"zoomOutRight",
"zoomOutUp",
"slideInDown",
"slideInLeft",
"slideInRight",
"slideInUp",
"slideOutDown",
"slideOutLeft",
"slideOutRight",
"slideOutUp"
)
A demo of these effects is available here.
In addition to the duration option, the JavaScript function animateCSS (used in js) also accepts a delay option, if you want to delay the animation.
You can improve this solution by allowing to set the desired effect and its options in session$sendCustomMessage:
js <- HTML(
'$(document).on("shiny:connected", function() {',
' Shiny.addCustomMessageHandler("animate", function(tab_and_options) {',
' var tab = tab_and_options.tab;',
' var o = tab_and_options.options;',
' var $tab = $("div.tab-pane[data-value=\\\"" + tab + "\\\"]");',
' var $imgs = $tab.find(".shiny-image-output");',
' $imgs.animateCSS(o.effect, {duration: o.duration, delay: o.delay});',
' });',
'});'
)
session$sendCustomMessage("animate", list(
tab = input$tabs,
options = list(
effect = "bounceInLeft",
duration = 1000,
delay = 100
)
))
EDIT
The images are visible during a very small moment before the animation starts. It seems that this code prevents this issue:
js <- HTML(
'$(document).ready(function() {',
' $("a[data-toggle=tab]").on("hide.bs.tab", function(e) {',
' var tab = $(e.target).data("value");',
' var $tab = $("div.tab-pane[data-value=\\\"" + tab + "\\\"]");',
' $tab.find(".shiny-image-output").css("visibility", "hidden");',
' });',
'});',
'$(document).on("shiny:connected", function() {',
' Shiny.addCustomMessageHandler("animate", function(tab_and_options) {',
' var tab = tab_and_options.tab;',
' var o = tab_and_options.options;',
' var $tab = $("div.tab-pane[data-value=\\\"" + tab + "\\\"]");',
' var $imgs = $tab.find(".shiny-image-output");',
' $imgs.animateCSS(o.effect, {duration: o.duration, delay: o.delay});',
' });',
'});'
)

Animation/transition for Shiny conditionalPanel

Shiny conditionalPanels just abruptly appear then disappear. Is there any way to make them slide or fade or otherwise gently transition?
Here is a way to fade the element when it is shown:
js <- "
$(document).ready(function(){
$('#plotContainer').on('show', function(event){
$(this).css('opacity', 0).animate({opacity: 1}, {duration: 1000});
});
});
"
ui <- fluidPage(
tags$head(tags$script(HTML(js))),
sidebarPanel(
actionButton("showplot", "Show")
),
mainPanel(
conditionalPanel(
condition = "input.showplot > 0",
id = "plotContainer",
plotOutput("plot")
)
)
)
server <- function(input, output) {
x <- rnorm(100)
y <- rnorm(100)
output$plot <- renderPlot({
plot(x, y)
})
}
shinyApp(ui, server)
EDIT
And also an effect on the hide event:
js <- "
$(document).ready(function(){
$('#plotContainer').on('show', function(){
$(this).css('opacity', 0).animate({opacity: 1}, {duration: 1000});
}).on('hide', function(){
var $this = $(this);
setTimeout(function(){
$this.show().hide(1000);
})
});
});
"
ui <- fluidPage(
tags$head(tags$script(HTML(js))),
sidebarPanel(
actionButton("showplot", "Show/Hide")
),
mainPanel(
conditionalPanel(
condition = "input.showplot % 2 == 1",
id = "plotContainer",
plotOutput("plot")
)
)
)
server <- function(input, output) {
x <- rnorm(100)
y <- rnorm(100)
output$plot <- renderPlot({
plot(x, y)
})
}
shinyApp(ui, server)
EDIT
Funny effects with the libraries Animate.css and jQuery-animateCSS:
js <- "
$(document).ready(function(){
$('#plotContainer').on('show', function(){
var $this = $(this);
$this.css('opacity', 0).
animate({opacity: 1}, 500, function(){
$this.animateCSS('jello', {
delay: 0,
duration: 2000
});
});
}).on('hide', function(){
var $this = $(this);
setTimeout(function(){
$this.show().animateCSS('heartBeat', {
delay: 0,
duration: 2000,
callback: function(){$this.hide(500);}
});
}, 0);
});
});
"
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/animate.css/4.1.0/animate.compat.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/animateCSS/1.2.2/jquery.animatecss.min.js"),
tags$script(HTML(js))
),
sidebarPanel(
actionButton("showplot", "Show/Hide")
),
mainPanel(
conditionalPanel(
condition = "input.showplot % 2 == 1",
id = "plotContainer",
plotOutput("plot")
)
)
)
server <- function(input, output) {
x <- rnorm(100)
y <- rnorm(100)
output$plot <- renderPlot({
plot(x, y)
})
}
shinyApp(ui, server)
EDIT
I've done some convenient R functions to bind these animations in a Shiny app. Here is the code:
library(shiny)
animateCSS <- function(effect, delay = 0, duration = 500, then = NULL){
effect <- match.arg(effect, c(
"bounce",
"flash",
"pulse",
"rubberBand",
"shakeX",
"shakeY",
"headShake",
"swing",
"tada",
"wobble",
"jello",
"heartBeat",
"backInDown",
"backInLeft",
"backInRight",
"backInUp",
"backOutDown",
"backOutLeft",
"backOutRight",
"backOutUp",
"bounceIn",
"bounceInDown",
"bounceInLeft",
"bounceInRight",
"bounceInUp",
"bounceOut",
"bounceOutDown",
"bounceOutLeft",
"bounceOutRight",
"bounceOutUp",
"fadeIn",
"fadeInDown",
"fadeInDownBig",
"fadeInLeft",
"fadeInLeftBig",
"fadeInRight",
"fadeInRightBig",
"fadeInUp",
"fadeInUpBig",
"fadeInTopLeft",
"fadeInTopRight",
"fadeInBottomLeft",
"fadeInBottomRight",
"fadeOut",
"fadeOutDown",
"fadeOutDownBig",
"fadeOutLeft",
"fadeOutLeftBig",
"fadeOutRight",
"fadeOutRightBig",
"fadeOutUp",
"fadeOutUpBig",
"fadeOutTopLeft",
"fadeOutTopRight",
"fadeOutBottomRight",
"fadeOutBottomLeft",
"flip",
"flipInX",
"flipInY",
"flipOutX",
"flipOutY",
"lightSpeedInRight",
"lightSpeedInLeft",
"lightSpeedOutRight",
"lightSpeedOutLeft",
"rotateIn",
"rotateInDownLeft",
"rotateInDownRight",
"rotateInUpLeft",
"rotateInUpRight",
"rotateOut",
"rotateOutDownLeft",
"rotateOutDownRight",
"rotateOutUpLeft",
"rotateOutUpRight",
"hinge",
"jackInTheBox",
"rollIn",
"rollOut",
"zoomIn",
"zoomInDown",
"zoomInLeft",
"zoomInRight",
"zoomInUp",
"zoomOut",
"zoomOutDown",
"zoomOutLeft",
"zoomOutRight",
"zoomOutUp",
"slideInDown",
"slideInLeft",
"slideInRight",
"slideInUp",
"slideOutDown",
"slideOutLeft",
"slideOutRight",
"slideOutUp"
))
js <- paste(
" $this.animateCSS('%s', {",
" delay: %d,",
" duration: %d,",
" callback: function(){",
" %s",
" }",
" });",
sep = "\n"
)
sprintf(js, effect, delay, duration, ifelse(is.null(then), "", then))
}
onShowJS <- function(animation, fadeDuration){
sprintf(paste(
"$('#%%s>div').on('show', function(){",
" var $this = $(this);",
" $this.css('opacity', 0).animate({opacity: 1}, %d, function(){",
animation,
" });",
"});",
sep = "\n"
), fadeDuration)
}
onHideJS <- function(animation, fadeDuration){
paste(
"$('#%s>div').on('hide', function(){",
" var $this = $(this);",
" setTimeout(function(){",
sub(
"^(\\s.*?\\$this\\.animateCSS)",
"$this.show().animateCSS",
sub(
"\\{\n \n \\}",
sprintf("{$this.hide(%d);}", fadeDuration),
animation
)
),
" }, 0);",
"});",
sep = "\n"
)
}
animatedConditionalPanel <-
function(condition, ..., onShow = NULL, fadeIn = 600, onHide = NULL, fadeOut = 400){
id <- paste0("animateCSS-", stringi::stri_rand_strings(1, 15))
jsShow <- ifelse(!is.null(onShow), sprintf(onShowJS(onShow, fadeIn), id), "")
jsHide <- ifelse(!is.null(onHide), sprintf(onHideJS(onHide, fadeOut), id), "")
script <- tags$script(HTML(paste(jsShow,jsHide,sep="\n")))
condPanel <- conditionalPanel(condition, ...)
tags$div(id=id, tagList(condPanel, script))
}
You have to use animateCSS and animatedConditionalPanel only. The animateCSS function defines an animation. You can chain the animations with the then argument. The animatedConditionalPanel functions replaces conditionalPanel. Here is an example:
ui <- fluidPage(
tags$head(
tags$link(rel = "stylesheet", href = "https://cdnjs.cloudflare.com/ajax/libs/animate.css/4.1.0/animate.compat.min.css"),
tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/animateCSS/1.2.2/jquery.animatecss.min.js")
),
sidebarPanel(
actionButton("showplot", "Show/Hide")
),
mainPanel(
animatedConditionalPanel(
condition = "input.showplot % 2 == 0",
onShow = animateCSS("swing", duration = 1000, then = animateCSS("jello")),
fadeIn = 400,
onHide = animateCSS("pulse", then = animateCSS("bounce")),
plotOutput("plot")
)
)
)
server <- function(input, output) {
x <- rnorm(100)
y <- rnorm(100)
output$plot <- renderPlot({
plot(x, y)
})
}
shinyApp(ui, server)
UPDATE JUNE 2022
These animations will be available in the next version of the shinyGizmo package.
library(shiny)
library(shinyGizmo)
ui <- fluidPage(
sidebarPanel(
actionButton("showplot", "Show/Hide")
),
mainPanel(
fluidRow(
column(
10,
conditionalJS(
plotOutput("plot"),
condition = "input.showplot % 2 === 1",
jsCalls$animateVisibility("jello", "tada", duration = 1500)
)
),
column(2)
)
)
)
server <- function(input, output) {
x <- rnorm(100)
y <- rnorm(100)
output[["plot"]] <- renderPlot({
plot(x, y, pch = 19)
})
}
shinyApp(ui, server)

header direction in shiny data table

I've been using DT in my shiny apps for a while. I'm wondering if there is any option (easy way) to change a table header direction when the text is long (like rotate all colnames by 45 degree or something), This is a problem when you have many columns in a table.
Thanks,
Here is a short example:
library(shiny)
library(DT)
ui <- fluidPage(
mainPanel(
tabsetPanel(
tabPanel("Table", br(),
dataTableOutput("myTable"))
), width = 9
)
)
server <- function(input, output) {
output$myTable <- renderDataTable({
test <- data.frame(1:20, letters[1:20], stringsAsFactors = FALSE)
colnames(test) <- c("This is a long name", "This column name is much more longer!")
datatable(test, rownames = FALSE, options = list(autoWidth = TRUE, searching = TRUE, lengthMenu = list(c(5, 10, 25, 50, -1), c('5', '10', '25', '50', 'All')), pageLength = 10)) # %>% formatStyle(names(test))
})
}
shinyApp(ui, server)
Here is a way to rotate the headers by 90 degrees.
library(DT)
library(shiny)
headerCallback <- c(
"function(thead, data, start, end, display){",
" var $ths = $(thead).find('th');",
" $ths.css({'vertical-align': 'bottom', 'white-space': 'nowrap'});",
" var betterCells = [];",
" $ths.each(function(){",
" var cell = $(this);",
" var newDiv = $('<div>', {height: 'auto', width: cell.height()});",
" var newInnerDiv = $('<div>', {text: cell.text()});",
" newDiv.css({margin: 'auto'});",
" newInnerDiv.css({",
" transform: 'rotate(180deg)',",
" 'writing-mode': 'tb-rl',",
" 'white-space': 'nowrap'",
" });",
" newDiv.append(newInnerDiv);",
" betterCells.push(newDiv);",
" });",
" $ths.each(function(i){",
" $(this).html(betterCells[i]);",
" });",
"}"
)
ui <- fluidPage(
DTOutput("table")
)
server <- function(input, output){
output[["table"]] <- renderDT({
datatable(iris,
options = list(
headerCallback = JS(headerCallback),
columnDefs = list(
list(targets = "_all", className = "dt-center")
)
))
})
}
shinyApp(ui, server)

Resources