Tracking slider state

[RossPitman]

I’ve been incorporating a number of slick carousels (via slickR) into a large shiny app that I’m building. But I’ve run into a little issue that I’m hoping you wouldn’t mind advising me on.

To explain, I have two slick carousels on one shiny page, both showing >200 images. I need to track the index of each image that each carousel is centred on – basically I want to know, for carousel 1, whether I’m looking at image-1, image-2, or image-N; and likewise for carousel 2. To do this, I’ve used a bit of javascript, shown below, where “spcs_idntfctn_id_rf_1” is the outputId from slickROutput:

$(document).ready(function() {

    var n1 = "";

    $("#spcs_idntfctn_id_rf_1").on("afterChange", function(){

    n1 = document.getElementsByClassName("slick-current slick-active")[0].getAttribute("data-slick-index");

    Shiny.onInputChange("spcs_idntfctn_img_num_1_rf_1", n1);
  });

});

Basically, whenever I move through the images on a carousel, the javascript code tracks which image I’m looking at.

This javascript code works well when I have only one carousel, but when I have two carousels, the code doesn’t work. I suspect this is because shiny doesn’t really know which carousel is current (i.e., which carousel I’ve actually clicked on). I thought using “slick-current” would solve this issue, but it hasn’t.

Is there something wrong with my javascript code, or perhaps is there a simpler way to achieve this without javascript using slickR directly?

Many thanks!

[yonicd]

Thanks for trying the package.

slickR has shiny observers to track slider state. You can see an example here:

https://github.com/metrumresearchgroup/slickR/blob/master/Miscellaneous/shinyTest.R

[yonicd]

here is a quick explanation of what is in the example

network <- shiny::reactiveValues() # <- a new reactive object like input

# when the slider changes this happens
  shiny::observeEvent(input$slick_current,{
    clicked_slide <- input$slick_current$.clicked # <- last index clicked
    relative_clicked <- input$slick_current$.relative_clicked # <- last relative index clicked
    center_slide <- input$slick_current$.center # <- index of center image
    total_slide <- input$slick_current$.total # <- total number of slides in slick
    active_slide <- input$slick_current$.slide # <- index of the active image

# if an image is clicked on then update objects in the network object
    if(!is.null(clicked_slide)){
      network$clicked_slide <- clicked_slide
      network$center_slide <- center_slide
      network$relative_clicked <- relative_clicked
      network$total_slide <- total_slide
      network$active_slide <- active_slide
      }
  })

# this prints out to a text UI that state of all the objects in network.
  output$current <- renderText({
    l <- shiny::reactiveValuesToList(network)
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
  })

[RossPitman]

Thanks, Yoni. Appreciate your quick response. Unfortunately I still can't get this working. I've provided a reproducible example below.

suppressMessages({
  library(dplyr)
  library(htmlwidgets)
  library(slickR)
})

#NBA Team Logos
nbaTeams=c("ATL","BOS","BKN","CHA","CHI","CLE","DAL","DEN","DET","GSW",
       "HOU","IND","LAC","LAL","MEM","MIA","MIL","MIN","NOP","NYK",
       "OKC","ORL","PHI","PHX","POR","SAC","SAS","TOR","UTA","WAS")
teamImg=sprintf(paste0("https://i.cdn.turner.com/nba/nba/.element/",
                   "img/4.0/global/logos/512x512/bg.white/svg/%s.svg"),
            nbaTeams)
teamImg2=sprintf(paste0("https://i.cdn.turner.com/nba/nba/.element/",
                    "img/4.0/global/logos/512x512/bg.white/svg/%s.svg"),
             nbaTeams)

#Player Images
a1=read_html('http://www.espn.com/nba/depth') %>% 
  html_nodes(css = '#my-teams-table a')
a2=a1%>%html_attr('href')
a3=a1%>%html_text()
team_table=read_html('http://www.espn.com/nba/depth') %>% 
  html_table()
team_table=team_table[[1]][-c(1,2),]
playerTable=team_table%>%melt(,id='X1') %>% 
  arrange(X1,variable)
playerName=a2[grepl('[0-9]',a2)]
playerId=do.call('rbind',lapply(strsplit(playerName,'[/]'),
                            function(x) x[c(8,9)]))
playerId=playerId[playerId[,1]!='phi',]
playerTable$img=sprintf(paste0('http://a.espncdn.com/combiner/i?img=/",
                           "i/headshots/nba/players/full/%s.png&w=350&h=254'),
                    playerId[,1])

server <- function(input, output) {

  output$slick <- renderSlickR({
    slickR(obj = teamImg, slideId = 'ex1',height = 100,width='100%')
  })

  output$slick2 <- renderSlickR({
    slickR(obj = teamImg2, slideId = 'ex12',height = 100,width='100%')
  })

  network <- shiny::reactiveValues()
  network2 <- shiny::reactiveValues()

  shiny::observeEvent(input$slick_current,{
    clicked_slide <- input$slick_current$.clicked
    relative_clicked <- input$slick_current$.relative_clicked
    center_slide <- input$slick_current$.center
    total_slide <- input$slick_current$.total
    active_slide <- input$slick_current$.slide

    if(!is.null(clicked_slide)){
      network$clicked_slide <- clicked_slide
      network$center_slide <- center_slide
      network$relative_clicked <- relative_clicked
      network$total_slide <- total_slide
      network$active_slide <- active_slide
     }
   })

  output$current <- renderText({
    l <- shiny::reactiveValuesToList(network)
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
  })

  output$current2 <- renderText({
    l <- shiny::reactiveValuesToList(network)
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
   })

}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      shiny::verbatimTextOutput('current'),
      shiny::verbatimTextOutput('current2')
    ),
    mainPanel(slickROutput("slick",width='100%',height='100px'),
              slickROutput("slick2",width='100%',height='100px'))
  )
)

shinyApp(ui = ui, server = server)

At the moment, every time I flip through images within the upper slide, both text boxes update. Instead, I need just the top text box to update when I change the upper slide. Conversely, I need to the lower text box to update when the lower slide is changed. Is this possible using slickR?

Many thanks!

[yonicd]

they naming convention is not that obvious in the example... it is [outputId]_current so this is how to write it

server <- function(input, output) {

  output$slick <- renderSlickR({
    slickR(obj = teamImg, slideId = 'ex1',height = 100,width='100%')
  })

  output$slick2 <- renderSlickR({
    slickR(obj = teamImg2, slideId = 'ex12',height = 100,width='100%')
  })

  network <- shiny::reactiveValues()
  network2 <- shiny::reactiveValues()

  shiny::observeEvent(input$slick_current,{
    clicked_slide <- input$slick_current$.clicked
    relative_clicked <- input$slick_current$.relative_clicked
    center_slide <- input$slick_current$.center
    total_slide <- input$slick_current$.total
    active_slide <- input$slick_current$.slide

    if(!is.null(clicked_slide)){
      network$clicked_slide <- clicked_slide
      network$center_slide <- center_slide
      network$relative_clicked <- relative_clicked
      network$total_slide <- total_slide
      network$active_slide <- active_slide
    }
  })

  shiny::observeEvent(input$slick2_current,{
    clicked_slide <- input$slick2_current$.clicked
    relative_clicked <- input$slick2_current$.relative_clicked
    center_slide <- input$slick2_current$.center
    total_slide <- input$slick2_current$.total
    active_slide <- input$slick2_current$.slide

    if(!is.null(clicked_slide)){
      network2$clicked_slide <- clicked_slide
      network2$center_slide <- center_slide
      network2$relative_clicked <- relative_clicked
      network2$total_slide <- total_slide
      network2$active_slide <- active_slide
    }
  })

  output$current <- renderText({
    l <- shiny::reactiveValuesToList(network)
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
  })

  output$current2 <- renderText({
    l <- shiny::reactiveValuesToList(network2)
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
  })

}

[RossPitman]

Thanks, Yoni! I totally missed that, but it's actually so simple. slickR is a great package, thank you so much for developing it. This approach is so much cleaner than my earlier javascript approach. I do, however, have one last question related to this approach: does the reactive nature of "outputId"_current rely on the user having to click the image, or could it simply work by using the keyboard arrow keys (i.e., so shiny basically tracks the centre image, and returns the index, whenever the user hits the left or right arrow key). This is essentially what my javascript approach was doing--albeit in a very messy manner. Having to rely on clicking each image would be cumbersome for the user of the shiny app (esp when inspecting hundreds of images), so it would be great if this approach would work without having to click, but simply work when using the arrow keys. Hopefully there's a way to do this?

Many thanks!

[yonicd]

right now it works on a click, but i am always open to changes if it makes it easier to use. you can PR a change if you find a more user friendly solution

[RossPitman]

Thanks, Yoni. I'll submit a push request soon. Just before that though, I've noticed that your [outputId]_current suggestion doesn't quite work for input$slick2_current$.center, input$slick2_current$.total, and slick2_current$.slide. All three outputs return values from the previous slide, rather than the current slide. It seems shiny, or slick, still doesn't know which carousel is actually current. Example code below:

suppressMessages({
  library(shiny)
  library(dplyr)
  library(htmlwidgets)
  library(slickR)
  library(xml2)
})

#NBA Team Logos
nbaTeams=c("ATL","BOS","BKN","CHA","CHI","CLE","DAL","DEN","DET","GSW",
       "HOU","IND","LAC","LAL","MEM","MIA","MIL","MIN","NOP","NYK",
       "OKC","ORL","PHI","PHX","POR","SAC","SAS","TOR","UTA","WAS")
teamImg=sprintf(paste0("https://i.cdn.turner.com/nba/nba/.element/",
                   "img/4.0/global/logos/512x512/bg.white/svg/%s.svg"),
            nbaTeams[1:10])
teamImg2=sprintf(paste0("https://i.cdn.turner.com/nba/nba/.element/",
                    "img/4.0/global/logos/512x512/bg.white/svg/%s.svg"),
             nbaTeams[1:15])

server <- function(input, output) {

  output$slick <- renderSlickR({
    slickR(obj = teamImg, slideId = 'ex1',height = 100,width='100%')
  })

  output$slick2 <- renderSlickR({
    slickR(obj = teamImg2, slideId = 'ex9',height = 100,width='100%')
  })

  network <- shiny::reactiveValues()
  network2 <- shiny::reactiveValues()

  shiny::observeEvent(input$slick_current,{
    network_clicked_slide <- input$slick_current$.clicked
    network_relative_clicked <- input$slick_current$.relative_clicked
    network_center_slide <- input$slick_current$.center
    network_total_slide <- input$slick_current$.total
    network_active_slide <- input$slick_current$.slide

    if(!is.null(network_clicked_slide)){
      network$network_clicked_slide <- network_clicked_slide
      network$network_center_slide <- network_center_slide
      network$network_relative_clicked <- network_relative_clicked
      network$network_total_slide <- network_total_slide
      network$network_active_slide <- network_active_slide
    }
  })

  shiny::observeEvent(input$slick2_current,{
    network2_clicked_slide <- input$slick2_current$.clicked
    network2_relative_clicked <- input$slick2_current$.relative_clicked
    network2_center_slide <- input$slick2_current$.center
    network2_total_slide <- input$slick2_current$.total
    network2_active_slide <- input$slick2_current$.slide

    if(!is.null(network2_clicked_slide)){
      network2$network2_clicked_slide <- network2_clicked_slide
      network2$network2_center_slide <- network2_center_slide
      network2$network2_relative_clicked <- network2_relative_clicked
      network2$network2_total_slide <- network2_total_slide
      network2$network2_active_slide <- network2_active_slide
    }
  })

  output$current <- renderText({
    l <- shiny::reactiveValuesToList(network)
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
  })

  output$current2 <- renderText({
    l <- shiny::reactiveValuesToList(network2)
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
  })

}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      shiny::verbatimTextOutput('current'),
      shiny::verbatimTextOutput('current2')
    ),
    mainPanel(slickROutput("slick",width='100%',height='100px'),
          slickROutput("slick2",width='100%',height='100px'))
  )
)

shinyApp(ui = ui, server = server)

Is this error happening on your side too? Or is it just user error on my end?

Thanks, Ross.

[yonicd]

good catch. i'll see where the problem is in the js.

[RossPitman]

Hi Yoni, is there any update on this?

[yonicd]

sorry. haven't gotten to this yet.

[yonicd]

this commit https://github.com/metrumresearchgroup/slickR/commit/010aafe63f2f7144fb50f80956475f0084f3b8b4 should fix it. shiny observes now

# the value given to the outputId in  slickROutput(outputId = 'slick1')
active_slide <- input$slick_current$.slide 

active_slide
> "slick1"

[RossPitman]

Thanks, Yoni. That update seems to get closer to the issue, but it's still not fixed. Note that if you run the reproducible example above, and observe the 'network2 center slide', it still tracks the first slider and only updates when you click the first slider. Instead, it should update whenever you click the second slider. Also, 'network2 total slide' should reflect 15, but it still reflects 10.

[yonicd]

this should work now. i made the shiny observer a callback function, now it responds per slick. https://github.com/metrumresearchgroup/slickR/commit/6bd839918011b3d5feda925e1a49ac4665012413

[yonicd]

final commit https://github.com/metrumresearchgroup/slickR/commit/01671099ce988e0832f1d049b8a0f816e20d010e for this ... now there is an event observer for afterChange so now the arrow and keyboard are tracked by shiny.

here is the new example, the NULL that you will see for clicked is just to make it more obvious what is happening (arrow or click event).

suppressMessages({
  library(shiny)
  library(dplyr)
  library(htmlwidgets)
  library(slickR)
})

#NBA Team Logos
nbaTeams=c("ATL","BOS","BKN","CHA","CHI","CLE","DAL","DEN","DET","GSW",
           "HOU","IND","LAC","LAL","MEM","MIA","MIL","MIN","NOP","NYK",
           "OKC","ORL","PHI","PHX","POR","SAC","SAS","TOR","UTA","WAS")
teamImg=sprintf(paste0("https://i.cdn.turner.com/nba/nba/.element/",
                       "img/4.0/global/logos/512x512/bg.white/svg/%s.svg"),
                nbaTeams)
teamImg2=sprintf(paste0("https://i.cdn.turner.com/nba/nba/.element/",
                        "img/4.0/global/logos/512x512/bg.white/svg/%s.svg"),
                 nbaTeams)

#Player Images
a1=read_html('http://www.espn.com/nba/depth') %>% 
  html_nodes(css = '#my-teams-table a')
a2=a1%>%html_attr('href')
a3=a1%>%html_text()
team_table=read_html('http://www.espn.com/nba/depth') %>% 
  html_table()
team_table=team_table[[1]][-c(1,2),]
playerTable=team_table%>%melt(,id='X1') %>% 
  arrange(X1,variable)
playerName=a2[grepl('[0-9]',a2)]
playerId=do.call('rbind',lapply(strsplit(playerName,'[/]'),
                                function(x) x[c(8,9)]))
playerId=playerId[playerId[,1]!='phi',]
playerTable$img=sprintf(paste0('http://a.espncdn.com/combiner/i?img=/",
                               "i/headshots/nba/players/full/%s.png&w=350&h=254'),
                        playerId[,1])

server <- function(input, output) {

  output$slick <- renderSlickR({
    slickR(obj = teamImg, slideId = 'ex1',
           slickOpts = list(slidesToShow=3,centerMode=TRUE),
           height = 100,width='100%')
  })

  output$slick2 <- renderSlickR({
    slickR(obj = teamImg2, slideId = 'ex12',height = 100,width='100%')
  })

  network <- shiny::reactiveValues()
  network2 <- shiny::reactiveValues()

  shiny::observeEvent(input$slick_current,{

    clicked_slide <- input$slick_current$.clicked
    relative_clicked <- input$slick_current$.relative_clicked

    center_slide <- input$slick_current$.center
    total_slide <- input$slick_current$.total
    active_slide <- input$slick_current$.slider

    if(!is.null(center_slide)){

      network$center_slide <- center_slide
      network$total_slide  <- total_slide
      network$active_slide <- active_slide
    }

    if(!is.null(clicked_slide)){

      network$clicked_slide    <- clicked_slide
      network$relative_clicked <- relative_clicked
      network$center_slide     <- center_slide

      network$total_slide      <- total_slide

      network$active_slide     <- active_slide

      }else{

      network$clicked_slide <- NULL
      network$relative_clicked <- NULL

    }
  })

  shiny::observeEvent(input$slick2_current,{
    clicked_slide <- input$slick2_current$.clicked
    relative_clicked <- input$slick2_current$.relative_clicked
    center_slide <- input$slick2_current$.center
    total_slide <- input$slick2_current$.total
    active_slide <- input$slick2_current$.slider

    if(!is.null(center_slide)){

      network2$center_slide <- center_slide
      network2$total_slide  <- total_slide
      network2$active_slide <- active_slide
    }

    if(!is.null(clicked_slide)){

      network2$clicked_slide    <- clicked_slide
      network2$relative_clicked <- relative_clicked
      network2$center_slide     <- center_slide

      network2$total_slide      <- total_slide

      network2$active_slide     <- active_slide

    }else{

      network2$clicked_slide <- NULL
      network2$relative_clicked <- NULL

    }
  })

  output$current <- renderText({
    l <- shiny::reactiveValuesToList(network)
    l <- l[!sapply(l,is.null)]
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
  })

  output$current2 <- renderText({
    l <- shiny::reactiveValuesToList(network2)
    l <- l[!sapply(l,is.null)]
    paste(gsub('_',' ',names(l)), unlist(l),sep=' = ',collapse='\n')
  })

}

ui <- fluidPage(
  sidebarLayout(
    sidebarPanel(
      shiny::verbatimTextOutput('current'),
      shiny::verbatimTextOutput('current2')
    ),
    mainPanel(slickROutput("slick",width='100%',height='100px'),
              slickROutput(outputId = "slick2",width='100%',height='100px'))
  )
)

shinyApp(ui = ui, server = server)

[RossPitman]

Thanks, Yoni. This seems to do the trick! Thank you very much for your work on this. Really appreciate it.

[yonicd]

you're welcome