Related
I have a shiny app to load pictures and I should be able to select some of the images by clicking on them and the selected images will be recorded.
I want a function that I can select and mark pictures the same way you mark photos in the gallery of a phone.
Currently, I made an app that the selected images are replaced by an empty icon. Here is what I have tried:
ui <-fluidPage(column(
width=9,
align="center",
imageOutput(outputId = "img1", click = clickOpts(id = "img1_click", clip = FALSE),width = 150,height = 150,inline = TRUE)
,imageOutput(outputId = "img2", click = clickOpts(id = "img2_click", clip = FALSE),width = 150,height = 150,inline = TRUE)
))
server <- function(input, output, session) {
empty_img="/empty.jpeg"
vals=reactiveValues(img=list.files("/images/"))
vals2=reactiveValues(img=list.files("/images/"))
empty_img_to_normal_value=reactiveValues(m=1:length(vals$img))
output$img1 <- renderImage({
list(src = vals$img[1], width = "200", height = "200") } ,deleteFile = FALSE)
observeEvent(input$img1_click, {
if(empty_img_to_normal_value$m[1]==1){
vals$img[1]=empty_img
empty_img_to_normal_value$m[1]=0
}else{
vals$img[1]=vals2$img[1]
empty_img_to_normal_value$m[1]=1
}
})
output$img2 <- renderImage({
list(src = vals$img[2], width = "200", height = "200")} ,deleteFile = FALSE)
observeEvent(input$img2_click, {
if(empty_img_to_normal_value$m[2]==1){
vals$img[2]=empty_img
empty_img_to_normal_value$m[2]=0
}else{
vals$img[2]=vals2$img[2]
empty_img_to_normal_value$m[2]=1
}
})
}
Following our comments, I made a proper answer.
# list of images URLs, replace them with your images
lst_urls <- list("data/Rplot1.png", "data/Rplot1.png", "data/Rplot1.png", "data/Rplot1.png",
"data/Rplot5.png","data/Rplot5.png","data/Rplot5.png","data/Rplot5.png")
img_w <- "100%"
img_h <- 200
mod_img_UI <- function(id) {
ns <- NS(id)
tagList(
tags$style(".checkbox{margin-bottom: -40px;}"),
column(
width =2,
checkboxInput(
inputId = ns("select_img"), label = NULL
),
imageOutput(
outputId = ns("img"), width = img_w, height = img_h, inline = TRUE
)
)
)
}
mod_img_SERVER <- function(input, output, session, img_url){
ns <- session$ns
output$img <- renderImage({
list(src = img_url,
alt = "This is alternate text",
width = img_w,
height = img_h,
contentType = "image/png")
}, deleteFile = FALSE)
return(input$select_img)
}
ui <- fluidPage(
uiOutput("images")
)
server <- function(input, output, session) {
output$images <- renderUI({
lapply(
1:length(lst_urls),
function(i) {
mod_img_UI(id = paste0("img", i))
}
)
})
observe({
selected_imgs <- lapply(
1:length(lst_urls),
function(i) {
callModule(
module = mod_img_SERVER,
session = session,
id = paste0("img", i),
img_url = lst_urls[[i]]
)
}
)
print(paste("You picked :",lst_urls[unlist(selected_imgs)]))
})
}
shinyApp(ui, server)
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;
});
I have a shiny application where I am using update function so that filters are reactive with respect to each other. Not sure there is some issue in the code. The values are not reflecting here as expected (for example for "Rat" as 1, we cannot select "No" in another filter ("New") Can anyone help me here?
Is there any alternate way?
library(shiny)
data_13_Sam <- data.frame(
Ratings = c(1,2,3,4,5,1,2,3,4,5), flag = c("Yes","No","Yes","No","Yes","No","Yes","No","Yes","Yes")
)
ui <- fluidPage(
column(offset = 0, width = 1,uiOutput("rat")),
column(offset = 0, width = 2, uiOutput("nt")),
tableOutput('data')
)
server <- function(input, output, session) {
output$rat <- renderUI({
selectInput("rat1",label = tags$h4("Rat"),choices = unique(data_13_Sam$Ratings))
})
output$nt <- renderUI({
selectInput("nt1",label = tags$h4("New"),choices = unique(data_13_Sam$flag))
})
observeEvent(input$rat1, {
updateSelectInput(session = session, inputId = "nt1", choices = unique(data_13_Sam$flag[data_13_Sam$Ratings == input$rat1]))
})
observeEvent(input$nt1, {
updateSelectInput(session = session, inputId = "rat1", choices = unique(data_13_Sam$Ratings[data_13_Sam$flag == input$nt1]))
})
}
shinyApp(ui, server)
Your code works fine with shiny::selectInput, and removing second updateSelectInput(...) Please see code below.
library(shiny)
data_13_Sam <- data.frame(
Ratings = c(1,2,3,4,5,1,2,3,4,5), flag = c("Yes","No","Yes","No","Yes","No","Yes","No","Yes","Yes")
)
ui <- fluidPage(
column(offset = 0, width = 1,uiOutput("rat")),
column(offset = 0, width = 2, uiOutput("nt")),
tableOutput('data')
)
server <- function(input, output, session) {
output$rat <- renderUI({
shiny::selectInput("rat1",label = tags$h4("Rat"),choices = unique(data_13_Sam$Ratings))
})
output$nt <- renderUI({
shiny::selectInput("nt1",label = tags$h4("New"),choices = unique(data_13_Sam$flag))
})
observeEvent(input$rat1, {
shiny::updateSelectInput(session = session, inputId = "nt1", choices = unique(data_13_Sam$flag[data_13_Sam$Ratings == input$rat1]))
})
# observeEvent(input$nt1, {
# shiny::updateSelectInput(session = session, inputId = "rat1", choices = unique(data_13_Sam$Ratings[data_13_Sam$flag == input$nt1]))
# })
}
shinyApp(ui, server)
I'm working on a shiny dashboard that makes heavy use of shiny modules and my client has asked me to make it so that the same two inputs from my dashboard's various tabs take on the same values regardless of tab. I'm having a huge problem doing this and was able to recreate it using a toy example that you'll find below.
#app.R
library(data.table)
library(shiny)
library(ggplot2)
library(ggthemes)
library(shinythemes)
source("Modules.R")
penguins <<- as.data.table(palmerpenguins::penguins)
ui = uiOutput("ui")
inputs <<- reactiveValues(species = NULL, island = NULL)
server <- function(input, output, session) {
bill_species_server("tab1")
flipper_mass_scatter_server("tab2")
output$ui = renderUI({
fluidPage(
titlePanel("", "Penguin Dashboard"),
tabsetPanel(
tabPanel("Bill Length by Species",
ui_code("tab1")
),
tabPanel("Flipper Length by Body Mass",
ui_code("tab2")
)
)
)
})
}
# Run the application
shinyApp(ui = ui, server = server)
#Modules.R
ui_code = function (id) {
ns = NS(id)
sidebarLayout(position = "left",
sidebarPanel(
selectInput(ns("species"), "Choose 1+ species:", choices = penguins[, sort(unique(species))], multiple = TRUE),
selectInput(ns("island"), "Choose 1+ islands:", choices = penguins[, sort(unique(island))], multiple = TRUE)
),
mainPanel(
plotOutput(ns("plot"))
)
)
}
bill_species_server = function(id) {
moduleServer(id, function(input, output, session) {
observeEvent(inputs$species, ignoreInit = TRUE, ignoreNULL = TRUE, {
if (length(inputs$species) > 0) {
updateSelectInput(session = session, inputId = "species", selected = inputs$species)
}
})
observeEvent(inputs$island, ignoreInit = TRUE, ignoreNULL = TRUE, {
if (length(inputs$island) > 0) {
updateSelectInput(session = session, inputId = "island", selected = inputs$island)
}
})
output$plot = renderPlot({
if (length(input$species) > 0) {
penguins = penguins[species %in% input$species]
}
if (length(input$island) > 0) {
penguins = penguins[island %in% input$island]
}
ggplot(penguins) + geom_histogram(aes(x = `bill_length_mm`, fill = species)) + scale_fill_canva(palette = "Striking and energetic")
})
observeEvent(input$species, ignoreNULL = TRUE, ignoreInit = TRUE, {
inputs$species = input$species
})
observeEvent(input$island, ignoreNULL = TRUE, ignoreInit = TRUE, {
inputs$island = input$island
})
})
return(inputs)
}
flipper_mass_scatter_server = function (id) {
moduleServer(id, function(input, output, session) {
observeEvent(inputs$species, ignoreInit = TRUE, ignoreNULL = TRUE, {
if (length(inputs$species) > 0) {
updateSelectInput(session = session, inputId = "species", selected = inputs$species)
}
})
observeEvent(inputs$island, ignoreInit = TRUE, ignoreNULL = TRUE, {
if (length(inputs$island) > 0) {
updateSelectInput(session = session, inputId = "island", selected = inputs$island)
}
})
output$plot = renderPlot({
if (length(input$species) > 0) {
penguins = penguins[species %in% input$species]
}
if (length(input$island) > 0) {
penguins = penguins[island %in% input$island]
}
ggplot(penguins) + geom_point(aes(x = `flipper_length_mm`, y = body_mass_g, colour = species)) + scale_colour_canva(palette = "Striking and energetic")
})
observeEvent(input$species, ignoreNULL = TRUE, ignoreInit = TRUE, {
inputs$species = input$species
})
observeEvent(input$island, ignoreNULL = TRUE, ignoreInit = TRUE, {
inputs$island = input$island
})
})
return(inputs)
}
So the two inputs that I'm trying to link in this toy example are species and island. I've set it up so that when someone makes a new selection on either input, an observer should update a global variable which in this case I've labelled inputs. And then if inputs is updated, the other tab should then update its own selectInput.
Weirdly, I find that with this code, if I make my selections kind of slowly, all works just fine! However, the moment that I click 2+ choices in rapid succession, it causes an infinite loop to happen in the current tab where the second choice appears, then disappears, then appears... etc. Conversely, when I have 3 choices selected and try to delete options in rapid succession, it just doesn't let me delete all choices!!
So weird.
Anyone know what the problem is with my code, and how I can force the inputs in both tabs to keep the same values as chosen in the other tabs?
Thanks!
I significantly restructured how I approached this problem and came up with a solution. Basically, I used shinydashboard and decided that I would define the species and island selectInput controls outside of my modules.
The values to those controls were then passed to the modules as reactive objects that were then used to filter the data before the data got plotted. This works so much better now! Have a look at my two files:
#app.R
library(data.table)
library(shiny)
library(ggplot2)
library(ggthemes)
library(shinythemes)
library(shinydashboard)
source("Modules.R")
penguins <<- as.data.table(palmerpenguins::penguins)
ui = dashboardPage(header = dashboardHeader(title = "Penguin Dashboard"),
sidebar = dashboardSidebar(
sidebarMenu(id = "tabs",
selectInput("species", "Choose 1+ species:", choices = penguins[, sort(unique(species))], multiple = TRUE),
selectInput("island", "Choose 1+ islands:", choices = penguins[, sort(unique(island))], multiple = TRUE),
menuItem("Bill Length by Species", expandedName = "tab1", tabName = "tab1", startExpanded = TRUE,
sliderInput("mass", "Select a range of body masses:",
min = penguins[, min(body_mass_g, na.rm=TRUE)],
max = penguins[, max(body_mass_g, na.rm=TRUE)],
value = penguins[, range(body_mass_g, na.rm=TRUE)])
),
menuItem("Flipper Length by Body Mass", expandedName = "tab2", tabName = "tab2",
checkboxGroupInput("sex", "Choose sex of penguins:",
choices = c("male","female")))
)),
body = dashboardBody(
uiOutput("plots")
)
)
#inputs <<- reactiveValues(species = NULL, island = NULL)
server <- function(input, output, session) {
#inputs <- reactiveValues(species=input$species, island=input$island)
in_species = reactive({input$species})
in_island = reactive({input$island})
in_mass = reactive({input$mass})
in_sex = reactive({input$sex})
bill_species_server("tab1", in_species, in_island, in_mass)
flipper_mass_scatter_server("tab2", in_species, in_island, in_sex)
output$plots = renderUI({
validate(need(!is.null(input$sidebarItemExpanded), ""))
if (input$sidebarItemExpanded == "tab1") {
ui_code("tab1")
} else {
ui_code("tab2")
}
})
}
# Run the application
shinyApp(ui = ui, server = server)
#Modules.R
ui_code = function (id) {
ns = NS(id)
plotOutput(ns("plot"))
}
bill_species_server = function(id, in_species, in_island, in_mass) {
moduleServer(id, function(input, output, session) {
ns <- session$ns
output$plot = renderPlot({
if (length(in_species()) > 0) {
penguins = penguins[species %in% in_species()]
}
if (length(in_island()) > 0) {
penguins = penguins[island %in% in_island()]
}
penguins = penguins[body_mass_g %between% c(in_mass()[1], in_mass()[2])]
ggplot(penguins) + geom_histogram(aes(x = `bill_length_mm`, fill = species)) + scale_fill_canva(palette = "Striking and energetic")
})
})
}
flipper_mass_scatter_server = function (id, in_species, in_island, in_sex) {
moduleServer(id, function(input, output, session) {
output$plot = renderPlot({
if (length(in_species()) > 0) {
penguins = penguins[species %in% in_species()]
}
if (length(in_island()) > 0) {
penguins = penguins[island %in% in_island()]
}
if (length(in_sex()) > 0) {
penguins = penguins[sex %in% in_sex()]
}
ggplot(penguins) + geom_point(aes(x = `flipper_length_mm`, y = body_mass_g, colour = species)) + scale_colour_canva(palette = "Striking and energetic")
})
})
}
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)