Search code examples
javascriptcssrshinyslickr

SlickR Shiny R dynamically convert dots to images when filtering the carousel obj by user input

Have been working through this slickR problem for a while. I would greatly appreciate any input or fresh perspectives on how to resolve this issue or different ways to approach a solution.

There are two issues I've been working through:

The first I think can be solved using CSS, which I am not super familiar with, slickR seems to be creating multiple divs when the 'obj' is updated through the use of input$series. This is undesirable since it relocates the most recent div lower on the page. I tried using javascript, which I am also not very familiar with, to destroy the old slick using an observe event. Bonus points for a simple solution for that issue.

The main issue I am working to resolve is that I would like to convert the dots to images and have them update dynamically as each series is selected. The goal here is that I would like to have a larger image displayed above and a series of 'thumbnails' displayed below so that the user can have some idea of what each photo looks like without having to scroll through every image in the carousel.

My app is much more complicated than this example, but I am using slickR since it has a convenient way to access the current, active, and center slides, which I am using to filter an additional dataframe to render the display of information regarding each active/centered image in the carousel.

Here is an example which demonstrates both issues:

library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinydashboardPlus)
library(jsonlite)
library(htmltools)
library(htmlwidgets)
library(slickR)

fish <- c(
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banner.jpg",
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banggai-cardinalfish.jpg",
  "https://www.sonomamag.com/wp-content/uploads/2016/12/fish.jpg" )

butterfly <- c(
  "https://www.futurity.org/wp/wp-content/uploads/2019/02/viceroy-butterfly_1600.jpg",
  "https://harvardforest.fas.harvard.edu/sites/harvardforest.fas.harvard.edu/files/butterfly_giant_swallowtail_model.jpg",
  "https://www.butterflyidentification.com/wp-content/uploads/2019/02/Doris-Longwing-Butterfly-Images.jpg"
)

bird <- c(
  "http://www.cutepetname.com/wp-content/uploads/2018/11/funy-bird-names-feat-img.jpeg",
  "http://3.bp.blogspot.com/-mJ-Kw1mdLOo/UeLJx7vxsaI/AAAAAAAADkg/TfDHtuJnY7I/s1600/The-Cardinal-Bird.jpg",
  "https://images7.alphacoders.com/416/thumb-1920-416332.jpg"
)

df <- data.frame(fish=fish, butterfly=butterfly, bird=bird)
pics <- df[,"fish"]

ui <- dashboardPagePlus(
  useShinyjs(),
  
  header = dashboardHeaderPlus(disable = TRUE ),
  sidebar = dashboardSidebar(
    
    radioButtons('series', "Choose Series", 
                 choices = c("fish"="fish", "butterfly"="butterfly", "bird"="bird")
                 ) 
    ),
  
  body = dashboardBody(
    
    tags$script( sprintf("var dotObj = %s", jsonlite::toJSON( 'dots')) ),
    
    slickROutput('slickRCarousel'),
    
    uiOutput('dots')
    
  )
)



server <- function(input, output, session) {
  
  # unslick to counteract slick generating multiple divs?
   observeEvent(input$series, ignoreInit = TRUE, {
     runjs("$('.slickRCarousel').slick('unslick');")
    print(df[,input$series])
  })
  
 
  # observe({
  #   print(input$slickROutput_current$.clicked)
  # })
  
  output$dots <- renderPrint({
    c(df[,input$series])
  })
  
  
  # carousel setup
    cP2 <- JS("function(slick,index) {
          return '<a><img src= ' + dotObj[index] + '  width=30px height=30px></a>';
          }")
  
  opts <- 
    settings(
      initialSlide = 1,
      slidesToShow = 3,
      slidesToScroll = 1,
      centerMode = TRUE,
      focusOnSelect = TRUE,
      dots = TRUE,
      customPaging = cP2
    )
  
  output$slickRCarousel <- renderSlickR({
    
    slick_dots_logo <- slickR(
      obj = df[,input$series],
      height = 100,
      width = "95%"
    ) + opts
    
  })
  
  
}

shinyApp(ui, server)

Thank you in advance for taking the time to look at this!

EDIT 1: Clarification and Current Approach

Here is my current approach, attempting to pass a dynamic value through session$sendCustomMessage and update the variable responsible for rendering the slickR dots (or thumbnails).

The persistent issues are:

  • the carousel jumps when the radio buttons are changed
  • the thumbnails are not updating when the radio buttons are changed

code:

library(shiny)
library(shinyjs)
library(shinydashboard)
library(shinydashboardPlus)
library(jsonlite)
library(htmltools)
library(htmlwidgets)
library(slickR)

fish <- c(
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banner.jpg",
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banggai-cardinalfish.jpg",
 "https://www.sonomamag.com/wp-content/uploads/2016/12/fish.jpg" )

butterfly <- c(
  "https://www.futurity.org/wp/wp-content/uploads/2019/02/viceroy-butterfly_1600.jpg",
  "https://harvardforest.fas.harvard.edu/sites/harvardforest.fas.harvard.edu/files/butterfly_giant_swallowtail_model.jpg",
  "https://www.butterflyidentification.com/wp-content/uploads/2019/02/Doris-Longwing-Butterfly-Images.jpg"
)

bird <- c(
  "http://www.cutepetname.com/wp-content/uploads/2018/11/funy-bird-names-feat-img.jpeg",
  "http://3.bp.blogspot.com/-mJ-Kw1mdLOo/UeLJx7vxsaI/AAAAAAAADkg/TfDHtuJnY7I/s1600/The-Cardinal-Bird.jpg",
  "https://images7.alphacoders.com/416/thumb-1920-416332.jpg"
)

df <- data.frame(fish=fish, butterfly=butterfly, bird=bird)


ui <- dashboardPagePlus(
  useShinyjs(),
  
  header = dashboardHeaderPlus(disable = TRUE ),
  sidebar = dashboardSidebar(
    
    radioButtons('series', "Choose Series", 
                 choices = c("fish"="fish", "butterfly"="butterfly", "bird"="bird")
    )
  ),
  
  body = dashboardBody(
    
    # this sets thumbnails to always be fish, replacing with
    # df[,input$series] seems to cause an issue.
    tags$script( HTML(sprintf("var dotObj = %s", jsonlite::toJSON( df[,'fish'])) ) ), 
    
    #attempting to add a custom message handler to update the dots, but it doesn't
    # update
    tags$script("
                  Shiny.addCustomMessageHandler(setDots, function(newDots) {
                    var dotObj = newDots; 
                  });
                "),
    
    slickROutput('slickRCarousel')
    
  )
)


server <- function(input, output, session) {
  
  #custom message handler to update the dots, but it doesn't update
  observe({
    session$sendCustomMessage('setDots', jsonlite::toJSON( df[,input$series]))
    #print(jsonlite::toJSON( df[,input$series]))
  })
  
  # unslick to counteract slick generating multiple divs
  # and pushing the carousel down? It's not working
   observeEvent(input$series, ignoreInit = TRUE, {
     runjs("$('.slickRCarousel').slick('unslick');")
  })
  
  # slickR carousel setup
  cP2 <- JS(
    "function(slick,index) {
            return '<a><img src= ' + dotObj[index] + '  width=30px height=30px></a>';
          }" )
  
  opts <- 
    settings(
      initialSlide = 1,
      slidesToShow = 1,
      slidesToScroll = 1,
      centerMode = TRUE,
      focusOnSelect = TRUE,
      dots = TRUE,
      customPaging = cP2
    )
  
  output$slickRCarousel <- renderSlickR({
  slick_dots_thumb <- slickR(
      obj = df[,input$series],
      height = 100,
      width = "95%"
    ) + opts
    
  })
  
}

shinyApp(ui, server)

EDIT 2: Building on @ismirsehregal 's solution to the display and navigation

Last piece of the puzzle is returning the center or active slide value to the server. The slickR documentation states you can access it like this:

input$mySlick_current$.center

It may be the case that the output$mySlick needs to be created by renderSlickR({}), not renderUI({}).

Here is some updated code from @ismirsehregal 's solution:

library(shiny)
library(htmlwidgets)
library(slickR)

fish <- c(
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banner.jpg",
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banggai-cardinalfish.jpg",
  "https://www.sonomamag.com/wp-content/uploads/2016/12/fish.jpg"
)

butterfly <- c(
  "https://www.futurity.org/wp/wp-content/uploads/2019/02/viceroy-butterfly_1600.jpg",
  "https://harvardforest.fas.harvard.edu/sites/harvardforest.fas.harvard.edu/files/butterfly_giant_swallowtail_model.jpg",
  "https://www.butterflyidentification.com/wp-content/uploads/2019/02/Doris-Longwing-Butterfly-Images.jpg"
)

bird <- c(
  "http://www.cutepetname.com/wp-content/uploads/2018/11/funy-bird-names-feat-img.jpeg",
  "http://3.bp.blogspot.com/-mJ-Kw1mdLOo/UeLJx7vxsaI/AAAAAAAADkg/TfDHtuJnY7I/s1600/The-Cardinal-Bird.jpg",
  "https://images7.alphacoders.com/416/thumb-1920-416332.jpg"
)

df <- data.frame(fish = fish,
                 butterfly = butterfly,
                 bird = bird)

ui <- fluidPage(uiOutput("mySlick"),
                radioButtons(
                  'series',
                  "Choose Series",
                  choices = c(
                    "fish" = "fish",
                    "butterfly" = "butterfly",
                    "bird" = "bird"
                  )
                ),
                uiOutput('imageInfo')
                )

server <- function(input, output, session) {
  output$mySlick <- renderUI({
    cP2 <- JS(
      "function(slick,index) {
          return '<a><img src= ' + dotObj[index] + '  width=100% height=100%></a>';
          }"
    )
    
    opts_dot_logo <-
      settings(
        initialSlide = 1,
        slidesToShow = 1,
        slidesToScroll = 3,
        centerMode = TRUE,
        focusOnSelect = TRUE,
        dots = TRUE,
        customPaging = cP2
      )
    
    s2 <- htmltools::tags$script(sprintf("var dotObj = %s", jsonlite::toJSON(df[[input$series]])))
    
    slick_dots_logo <- slickR(obj = df[[input$series]],
                              height = 100,
                              width = "95%") + opts_dot_logo
    
    htmltools::tagList(s2, slick_dots_logo)
  })
  
  observeEvent(input$series, ignoreInit = TRUE, {
  
  output$imageInfo <- renderPrint({
    paste("The center image is: ", input$mySlick_current$.center)
    })
  
  #print(input$mySlick_current$.center)
  })
  
  
}

shinyApp(ui, server)

Edit 3: Final Solution

Thanks to the link provided in the comment by @ismirsehregal I was able to pass the index of the center slide back to the server.

code:

library(shiny)
library(htmlwidgets)
library(slickR)

fish <- c(
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banner.jpg",
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banggai-cardinalfish.jpg",
  "https://www.sonomamag.com/wp-content/uploads/2016/12/fish.jpg"
)

butterfly <- c(
  "https://www.futurity.org/wp/wp-content/uploads/2019/02/viceroy-butterfly_1600.jpg",
  "https://harvardforest.fas.harvard.edu/sites/harvardforest.fas.harvard.edu/files/butterfly_giant_swallowtail_model.jpg",
  "https://www.butterflyidentification.com/wp-content/uploads/2019/02/Doris-Longwing-Butterfly-Images.jpg"
)

bird <- c(
  "http://www.cutepetname.com/wp-content/uploads/2018/11/funy-bird-names-feat-img.jpeg",
  "http://3.bp.blogspot.com/-mJ-Kw1mdLOo/UeLJx7vxsaI/AAAAAAAADkg/TfDHtuJnY7I/s1600/The-Cardinal-Bird.jpg",
  "https://images7.alphacoders.com/416/thumb-1920-416332.jpg"
)

js <- "
$(document).ready(function(){
  $('#mySlick').on('setPosition', function(event, slick) {
    var index = slick.currentSlide + 1;
    Shiny.setInputValue('imageIndex', index);
  });
})"

df <- data.frame(fish = fish,
                 butterfly = butterfly,
                 bird = bird)

ui <- fluidPage(
  tags$head(
    tags$script(HTML(js))
  ),
  
  uiOutput("mySlick"),
                radioButtons(
                  'series',
                  "Choose Series",
                  choices = c(
                    "fish" = "fish",
                    "butterfly" = "butterfly",
                    "bird" = "bird"
                  )
                ),
                uiOutput('imageInfo')
                )

server <- function(input, output, session) {
  output$mySlick <- renderUI({
    cP2 <- JS(
      "function(slick,index) {
          return '<a><img src= ' + dotObj[index] + '  width=100% height=100%></a>';
          }"
    )
    
    opts_dot_logo <-
      settings(
        initialSlide = 1,
        slidesToShow = 1,
        slidesToScroll = 3,
        centerMode = TRUE,
        focusOnSelect = TRUE,
        dots = TRUE,
        customPaging = cP2
      )
    
    s2 <- htmltools::tags$script(sprintf("var dotObj = %s", jsonlite::toJSON(df[[input$series]])))
    
    slick_dots_logo <- slickR(obj = df[[input$series]],
                              height = 100,
                              width = "95%") + opts_dot_logo
    
    htmltools::tagList(s2, slick_dots_logo)
  })
  
  observeEvent(input$series, ignoreInit = TRUE, {
  
  output$imageInfo <- renderPrint({
    paste("The center image is: ", df[[input$series]][input[['imageIndex']]])
    })
  print(input[['imageIndex']])
  print( df[[input$series]][input[['imageIndex']]] )
  })
  
  
}

shinyApp(ui, server)
Solution

  • Here is what I think you are after (I didn't use shinydashboardPlus as it isn't relevant regarding the given problem)

    Edit: After some fixes you can now achive the same using renderSlickR. You need to install a version including the latest commit:

    remotes::install_github("yonicd/slickR@417fd60e013b70540970c1b798897050c3580d2c")

    Now also available in a branch:

    remotes::install_github("yonicd/slickR@fix_shinyvignette")

    Furthermore I found out, that you can avoid the jumping on re-rendering issue via passing the height argument as character (see ?slickR - valid css unit e.g. "100px" or "25vh").

    library(shiny)
library(htmlwidgets)
library(slickR)

DF <- data.frame(fish = c(
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banner.jpg",
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banggai-cardinalfish.jpg",
  "https://www.sonomamag.com/wp-content/uploads/2016/12/fish.jpg"
),
butterfly = c(
  "https://www.futurity.org/wp/wp-content/uploads/2019/02/viceroy-butterfly_1600.jpg",
  "https://harvardforest.fas.harvard.edu/sites/harvardforest.fas.harvard.edu/files/butterfly_giant_swallowtail_model.jpg",
  "https://www.butterflyidentification.com/wp-content/uploads/2019/02/Doris-Longwing-Butterfly-Images.jpg"
),
bird = c(
  "http://www.cutepetname.com/wp-content/uploads/2018/11/funy-bird-names-feat-img.jpeg",
  "http://3.bp.blogspot.com/-mJ-Kw1mdLOo/UeLJx7vxsaI/AAAAAAAADkg/TfDHtuJnY7I/s1600/The-Cardinal-Bird.jpg",
  "https://images7.alphacoders.com/416/thumb-1920-416332.jpg"
))

ui <- fluidPage(slickROutput("mySlick", width = "50%"),
                radioButtons(
                  'series',
                  "Choose Series",
                  choices = c(
                    "fish" = "fish",
                    "butterfly" = "butterfly",
                    "bird" = "bird"
                  )
                ),
                textOutput("center"))

server <- function(input, output, session) {
  output$mySlick <- renderSlickR({

    cP2 <- JS(
      paste0("function(slick,index) {
      var dotObj = ", jsonlite::toJSON(DF[[input$series]]),";
          return '<a><img src= ' + dotObj[index] + '  width=100% height=100%></a>';
          }"))
    
    opts_dot_logo <-
      settings(
        initialSlide = 1,
        slidesToShow = 1,
        slidesToScroll = 3,
        centerMode = TRUE,
        focusOnSelect = TRUE,
        dots = TRUE,
        customPaging = cP2
      )
    
    slick_dots_logo <- slickR(obj = DF[[input$series]],
                              height = "100px") + opts_dot_logo
    
    
    slick_dots_logo
  })
  
  output$center <- renderText({
    paste("Center:", input$mySlick_current$.center)
  })
  
}

shinyApp(ui, server)

    renderUI solution:

    library(shiny)
library(htmlwidgets)
library(slickR)

fish <- c(
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banner.jpg",
  "https://www.hakaimagazine.com/wp-content/uploads/aquarium-reef-fish-banggai-cardinalfish.jpg",
  "https://www.sonomamag.com/wp-content/uploads/2016/12/fish.jpg"
)

butterfly <- c(
  "https://www.futurity.org/wp/wp-content/uploads/2019/02/viceroy-butterfly_1600.jpg",
  "https://harvardforest.fas.harvard.edu/sites/harvardforest.fas.harvard.edu/files/butterfly_giant_swallowtail_model.jpg",
  "https://www.butterflyidentification.com/wp-content/uploads/2019/02/Doris-Longwing-Butterfly-Images.jpg"
)

bird <- c(
  "http://www.cutepetname.com/wp-content/uploads/2018/11/funy-bird-names-feat-img.jpeg",
  "http://3.bp.blogspot.com/-mJ-Kw1mdLOo/UeLJx7vxsaI/AAAAAAAADkg/TfDHtuJnY7I/s1600/The-Cardinal-Bird.jpg",
  "https://images7.alphacoders.com/416/thumb-1920-416332.jpg"
)

df <- data.frame(fish = fish,
                 butterfly = butterfly,
                 bird = bird)

ui <- fluidPage(uiOutput("mySlick"),
                radioButtons(
                  'series',
                  "Choose Series",
                  choices = c(
                    "fish" = "fish",
                    "butterfly" = "butterfly",
                    "bird" = "bird"
                  )
                ))

server <- function(input, output, session) {
  output$mySlick <- renderUI({
    cP2 <- JS(
      "function(slick,index) {
          return '<a><img src= ' + dotObj[index] + '  width=100% height=100%></a>';
          }"
    )
    
    opts_dot_logo <-
      settings(
        initialSlide = 1,
        slidesToShow = 1,
        slidesToScroll = 3,
        centerMode = TRUE,
        focusOnSelect = TRUE,
        dots = TRUE,
        customPaging = cP2
      )
    
    s2 <- htmltools::tags$script(sprintf("var dotObj = %s", jsonlite::toJSON(df[[input$series]])))
    
    slick_dots_logo <- slickR(obj = df[[input$series]],
                              height = 100,
                              width = "95%") + opts_dot_logo
    
    htmltools::tagList(s2, slick_dots_logo)
  })
  
}

shinyApp(ui, server)

    result