1

I have a shiny app where I have a slick slideshow and inputs that are associated with each image. The user will put in their name and then guess the age of each person in the photo. Every time the user advances the slide with the arrow the inputs will also advance. The user must fill out the inputs for the rest of the app to work (rest of app not shown here). What I would like is that every time the arrow is clicked the app will check to see if the associated input is empty and if it is the slideshow will not advance and a little message will pop up. I have tried to work out solutions with shinyjs and shinyvalidate and shinyalert but I can't come up with a solution.

library(shiny)
library(shinyalert)
library(slickR)
library(tidyverse)
library(shinyvalidate)
library(shinyjs)

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);
 
  var deleteThis = function(elem){
        elem.style.display = 'none';
        // elem.style.visibility = 'hidden';
};

})
"

slider <- "$('.slider').slick({
  autoplay: false,
  dots: true,
  customPaging : function(slider, i) {
    var thumb = $(slider.$slides[i]).data();
    
    return '<a>'+1:6[i]+'</a>';
  },
  responsive: [{ 
    breakpoint: 500,
    settings: {
      dots: false,
      arrows: false,
      infinite: false,
      slidesToShow: 2,
      slidesToScroll: 2
    } 
  }]
});"

cP1=htmlwidgets::JS("function(slick,index) {return '<a>'+(index+1)+'</a>';}")

imgs <- list.files("samplepictures/", pattern=".jpg|.jpeg|.png", full.names = TRUE)
imgs <- imgs[!grepl("photo_ages",imgs)]

photoages <- lapply(1:6,function(x){ numericInput(paste0("Photo",x),
                                                  paste0("Photo ",x," Age Guess:"),
                                                  min = 1,
                                                  max = 100,
                                                  value = NULL)})

texfn <- function(x= "Guesser"){
  textInput("Name",paste(x))
}
actionfn <- function(){
  actionButton("go", "Submit All Guesses")
}

photoages <- as.vector(photoages)

photoages <- c(list(texfn()),
               photoages,
               list(actionfn()))

ui <- fluidPage(
  useShinyjs(),
  
  titlePanel("Photo Guesses"),
  mainPanel(

    tags$head(
      tags$script(HTML(js))
    ),
    tags$head(
      tags$style(HTML("
    .arrows {
      height: 30px;
    }
    .slick-prev {
      left: 10px; # moves right
    }
    .slick-next {
      left: 30px;  # moves right
    }
    "))),
    
    fluidRow(
      column(12),
      column(4,align = "left",tags$body( div(id = "mydiv",uiOutput("photoinput"))) ) ,
      column(4, align = "left",div(id = "npht",h4("Advance:")), tags$br(), tags$div(id = "arr",class="arrows"))
    ),

    tags$hr(),
    slickROutput("slickr") ,
    tags$br()
    
  )
)

server <- function(input, output,session) {
 
  iv <- InputValidator$new()
  iv$add_rule("Name", sv_required())
  iv$add_rule("Photo1", sv_between(1,100, allow_na = T))
  iv$add_rule("Photo2", sv_between(1,100, allow_na = T))
  iv$add_rule("Photo3", sv_between(1,100, allow_na = T))
  iv$add_rule("Photo4", sv_between(1,100, allow_na = T))
  iv$add_rule("Photo5", sv_between(1,100, allow_na = T))
  iv$add_rule("Photo6", sv_between(1,100, allow_na = T))
  iv$enable()
  
  
  observeEvent(input[["imageIndex"]],{
    values <- reactiveValues()
    
    values$click <- input[["imageIndex"]]
    if(input[["imageIndex"]] >7){
      removeUI("#npht")
      removeUI("#arr")
    }
    
  })
  

  output$slickr <- renderSlickR({
    
    
    imgs <- list.files("samplepictures/", pattern=".jpg|.jpeg|.png", full.names = TRUE)
    imgs <- imgs[!grepl("photo_ages",imgs)]
    (slickR(imgs) +
        
        slickR::settings(dots = TRUE,
                         #customPaging = cP1,
                         appendArrows = '.arrows',
                         prevArrow = "null"
        )) 
  })
  
  output[["photoinput"]] <- renderUI({photoages[input[["imageIndex"]]]})
     
}

# Run the application
shinyApp(ui = ui, server = server)
Mike
  • 3,797
  • 1
  • 11
  • 30
  • There's a lot going on here. I haven't figured it all out yet, but what I can tell you: 1) the validations you've set look for ALL of these things to be met before the first image is shown. (So an age for each picture before any pictures.) The _name_ entry is shown with a picture, so the first _age_ is actually the name. You probably need to set the validation within the call for `observeEvent`; however, first, you have to separate the request for their name from the first image. – Kat Mar 10 '23 at 01:34
  • 1
    Oh, one other thing...if you're not already aware, it may make it easier if you use both Shiny's `options(shiny.trace = T)` and either RStudio's or your browser's developer tools (right-click on your app and select developer tools, lots of errors in the tab "console") – Kat Mar 10 '23 at 01:37
  • 1
    Not sure if this is an option for you, but I'd recommend using library([shinyglide](https://github.com/juba/shinyglide/)) and its built-in [conditional controls](https://juba.github.io/shinyglide/articles/b_conditionals.html). – ismirsehregal Mar 10 '23 at 08:47
  • I should also mention I tried to use %synch% from the slickR package but had little luck there @Kat – Mike Mar 10 '23 at 14:17
  • @ismirsehregal `shinyglide` worked perfectly! I can write up my answer or if you want to I'd be happy to defer to you – Mike Mar 13 '23 at 13:38
  • 1
    @Mike great to hear it works for you. Please feel free to answer yourself (i'm currently too short on time). Cheers – ismirsehregal Mar 13 '23 at 14:30

1 Answers1

1

You can replace the javascript code and slickR code with shinyglide as recommended by ismireshregal. I simplified it but you can prevent the slide from advancing if it doesn't meet a condition using the next_condition argument. See here for more information: https://juba.github.io/shinyglide/articles/b_conditionals.html.

library(shiny)
library(shinyglide)



ui <- fluidPage(

  mainPanel(
    glide(
      id = "plot-glide",
      controls_position = "top",
      next_label = "Go to next screen",
      previous_label = "Go Back",
      screen(
        next_condition = "input.Name != ''",
        p("Please enter your name:"),
        textInput("Name","Guesser")
        ),
      screen(
        next_condition = "input.Name2 != ''",
        textInput("Name2","Guesser")
        ),
      screen(
        next_condition = "input.Name3 != ''",
        textInput("Name3","Guesser")
      )
    )
    
  )
)

server <- function(input, output,session) {


  
}

# Run the application
shinyApp(ui = ui, server = server)
Mike
  • 3,797
  • 1
  • 11
  • 30