0

Like in a previous question: How to listen for more than one event expression within a Shiny eventReactive handler

I'm wanting to listen for two events in my eventReactive expression, however in this case one event is more complicated than a single input and I cant get both the simple first event and the second more complicated event to both work together.

The first event is input$start an actionButton that self deletes once clicked using removeUI() and the second requires two inputs to trigger; input$nxt which is an action button which requires a box to be ticked on a radioButtons widget (input$choice) to trigger the event.

Both events trigger the same bit of code, which is a function I've written to randomly generate 2 photos from a database. The user then has to choose the which of the two photos they like most (the radioButton input$choice) and click the actionButton input$nxt to proceed.

The line I'm struggling with is rv <- eventReactive(input$start |{req(input$nxt, isolate(input$choice))}, mysample(filenames)) It currently only reacts to the second expression {req(input$nxt, isolate(input$choice))}.

If I don't include the isolate(input$choice) and have: rv <- eventReactive(input$start |input$nxt, mysample(filenames)) then it reacts fine to both.

Any help would be hugely appreciated:

My full code is as follows:

orig.filenames <- 1:10
filenames <- orig.filenames

mysample <- function(x){
  tmp <- sample(x,2)
  filenames <<- setdiff(filenames, tmp)
  if(length(filenames) < 3) filenames <<- orig.filenames
  tmp
}

ui <- fluidPage(
    fluidRow(uiOutput(outputId = "uiimg1"), uiOutput(outputId = "uiimg2")),
    fluidRow(uiOutput("radio")),
    fluidRow(uiOutput("nxt")),
    fluidRow(tags$div(HTML("<center>"),
                      actionButton("start", "Start"),
                      'id' = "strtbtn"))) 

server <- function(input, output) {

    rv <- eventReactive(input$start |{req(input$nxt, isolate(input$choice))}, 
    mysample(filenames))

    observeEvent(input$start,
                 {output$uiimg1<- renderUI(column(6, HTML("<center>Left Image"),
                                       fluidRow(imageOutput(outputId = "img1"))))})

    observeEvent(input$start,
                 {output$uiimg1<- renderUI(column(6, HTML("<center>Right Image"),
                                       fluidRow(imageOutput(outputId = "img2"))))})

    observeEvent(input$start,
                 {output$nxt <- renderUI(wellPanel(HTML("<center>"),
                                         actionButton("nxt","Next")))})
    observeEvent(input$start,
                 {output$radio<- renderUI(
                   wellPanel(HTML("<center>"), 
                    radioButtons(inputId = "choice",
                                 label = "Which photo do you prefer?",
                                 c("Left", "Right"),
                                 inline = TRUE, selected = character (0)
                    )))})

    observeEvent(input$nxt,
                 {output$radio<- renderUI(
                   wellPanel(HTML("<center>"), 
                    radioButtons(inputId = "choice",
                                 label = "Which photo do you prefer?",
                                 c("Left", "Right"),
                                 inline = TRUE, selected = character (0)
                    )))})

    observeEvent(input$start,
               removeUI(selector = "div:has(> #strtbtn)", immediate = TRUE))

  output$img1 <- renderImage({
    filename1<- normalizePath(path= 
                            paste('/Users/Ben/Documents/Masters/Stats/Shiny/v8/www/',
                                   paste(rv()[1], '.jpg', sep = ''), sep =''))
    list(src = filename1, width=325, height=214)
}, deleteFile= FALSE)

  output$img2 <- renderImage({
    filename2<- normalizePath(path= 
                            paste('/Users/Ben/Documents/Masters/Stats/Shiny/v8/www/',
                                   paste(rv()[2], '.jpg', sep = ''), sep =''))
    list(src = filename1, width=325, height=214)
}, deleteFile= FALSE)

}

shinyApp(ui = ui, server = server)
BCul
  • 1
  • 1
  • 5

1 Answers1

3

I couldn't reproduce your example, so I'm not exactly sure what your problem is (see Friendly Tips, below), but I'll try to answer it based on your description.

But, first things first. You said that you are struggling with rv <- eventReactive(input$start |{req(input$nxt, isolate(input$choice))}, mysample(filenames)), right?

Well, one thing that we have to keep in mind if that when we are comparing things in R using thing 1 | thing 2, R only compares objects that are numeric, logical or complex. To see what I mean, type 1 | "a" and see what happens.

That being said, even if you had the correct syntax, R would not be able to compute input$start |{req(input$nxt, isolate(input$choice))} because the moment the user chooses "Left" or "Right", input$choice becomes a character and you would get the same error as in 1 | "a".

When you run rv <- eventReactive(input$start |input$nxt, mysample(filenames)), it works because both input$start and input$nxt have the same type.

Now, back to your problem: if I understood correctly, after you press "Start" you generate two numbers that will give you the file names. Then, you want to plot the respective images and the user has to select which one they prefer. Based on the selected image, you want to change the other image, selecting it at random from the remaining files. Is that it?

If that's the case, one way you could solve it would be by having two eventReactive statements. The first one to get the initial two numbers after the user presses "Start", and the other to update one of those two initial numbers, depending on the user choice.

The first one would have only one requirement:

rv.init <- eventReactive(input$start, {...})

While we could use the following for the second one (although input$start is redundant in this case):

  rv.cond <- eventReactive(input$start | input$nxt, {

    req(input$choice)
    ...
  })

You can see a working example here of the code below:

library(shiny)

ui <- fluidPage(
  # ADDED UI OUTPUTS ----------------------------------------------------------#
  fluidRow(h6("Original Filenames"), verbatimTextOutput("originalFilenames")),
  fluidRow(h6("Remaining Filenames"), verbatimTextOutput("remainingFilenames")),
  fluidRow(h6("Initial Sample"), verbatimTextOutput("initialSample")),
  fluidRow(h6("New Sample - user choice fixed"), verbatimTextOutput("newSample")),
  #----------------------------------------------------------------------------#
  fluidRow(uiOutput(outputId = "uiimg1"), uiOutput(outputId = "uiimg2")),
  fluidRow(uiOutput("radio")),
  fluidRow(uiOutput("nxt")),
  fluidRow(tags$div(HTML("<center>"),
                    actionButton("start", "Start"),
                    'id' = "strtbtn")))

server <- function(input, output) {

  # CHANGES TO THE ORIGINAL FUNCTION ------------------------------------------#

  # Generate file names
  orig.filenames <- 1:10

  # Create a reactive variable with filenames
  ## Reactive in the sense that we will update its values by removing the 
  ## selected ones
  filenames <- reactiveValues(names = orig.filenames)

  # Function to get 1 sample observation out of the remaining filenames
  mysample <- function(x){
    tmp <- sample(x,1)
    filenames$names <- setdiff(filenames$names, tmp)
    if(length(filenames$names) < 3) filenames$names <- orig.filenames
    tmp
  }

  #----------------------------------------------------------------------------#

  # CREATE EMPTY SAMPLE SET 

  files <- reactiveValues(sample = c(NA, NA))

  #----------------------------------------------------------------------------#

  # FIRST eventReactive -------------------------------------------------------#

  # Get initial sample of files when user clicks 'start'
  rv.init <- eventReactive(input$start, {

    ## Generate 1st time LEFT value
    left <- mysample(filenames$names)

    ## Generate 1st time RIGHT value
    right <- mysample(filenames$names)

    ## Create your initial sample in files$files
    tmp <- c(left, right)

    return(tmp)

  })

  # UPDATE SAMPLE SET WITH INITIAL VALUES
  observeEvent(input$start,  files$sample <- rv.init())

  #----------------------------------------------------------------------------#

  # SECOND eventReactive -------------------------------------------------------#

  # Get new sample file, based on user choice
  ## It will only update sample after user selects 'Left' or 'Right'
  rv.cond <- eventReactive(input$start | input$nxt, {

    req(input$choice)
    if (input$choice == "Left") {
      init.tmp <- files$sample
      init.tmp[2] <- mysample(filenames$names)
      tmp <- init.tmp
    }
    # Change first value (left value), if user selects "Right"
    else if (input$choice == "Right") {
      init.tmp <- files$sample
      init.tmp[1] <- mysample(filenames$names)
      tmp <- init.tmp
    }

    return(tmp)

  })

  # UPDATE SAMPLE SET WITH NEW VALUES
  observeEvent(input$nxt,  files$sample <- rv.cond())

  #----------------------------------------------------------------------------#

  observeEvent(input$start,
               {output$uiimg1<- renderUI(column(6, HTML("<center>Left Image"),
                                                fluidRow(imageOutput(outputId = "img1"))))})

  observeEvent(input$start,
               {output$uiimg2<- renderUI(column(6, HTML("<center>Right Image"),
                                                fluidRow(imageOutput(outputId = "img2"))))})

  observeEvent(input$start, 
               {output$nxt <- renderUI(wellPanel(HTML("<center>"),
                                                 actionButton("nxt","Next")))})
  observeEvent(input$start,
               {output$radio<- renderUI(
                 wellPanel(HTML("<center>"), 
                           radioButtons(inputId = "choice",
                                        label = "Which photo do you prefer?",
                                        c("Left", "Right"),
                                        inline = TRUE, selected = character (0)
                           )))})

  observeEvent(input$nxt,
               {output$radio<- renderUI(
                 wellPanel(HTML("<center>"), 
                           radioButtons(inputId = "choice",
                                        label = "Which photo do you prefer?",
                                        c("Left", "Right"),
                                        inline = TRUE, selected = character (0)
                           )))})

  observeEvent(input$start,
               removeUI(selector = "div:has(> #strtbtn)", immediate = TRUE))

  output$img1 <- renderImage({
    filename1 <- tempfile(fileext='.png')

    # CHANGED FROM THE ORIGINAL QUESTION --------------------------------------#
    # Set seed to filenames number from files$sample[1]
    set.seed(files$sample[1])

    # Generate a png
    png(filename1, width=325, height=214)
    hist(rnorm(50*files$sample[1]),  main = paste("Histogram of rnorm(50*" , files$sample[1], ")"))
    dev.off()
    #--------------------------------------------------------------------------#

    list(src = filename1, width=325, height=214)
  }, deleteFile= FALSE)

  output$img2 <- renderImage({
    filename2<- tempfile(fileext='.png')

    # CHANGED FROM THE ORIGINAL QUESTION --------------------------------------#
    # Set seed to filenames number from files$sample[2]
    set.seed(files$sample[2])

    # Generate a png
    png(filename2, width=325, height=214)
    hist(rnorm(50*files$sample[2]),  main = paste("Histogram of rnorm(50*" , files$sample[2], ")"))
    dev.off()
    #--------------------------------------------------------------------------#

    list(src = filename2, width=325, height=214)
  }, deleteFile= FALSE)

  # ADDED SERVER OUTPUTS ------------------------------------------------------#

  ## Print original filenames
  output$originalFilenames <- renderPrint({
    print(orig.filenames)
  })

  ## Print remaining filenames
  output$remainingFilenames <- renderPrint({
    print(filenames$names)
  })

  ## Print Initial Sample
  output$initialSample <- renderPrint({
    print(rv.init())
  })

  ## Print New Sample, keeping user choice fixed
  output$newSample <- renderPrint({
    req(input$start)
    print(files$sample)
  })

}

shinyApp(ui = ui, server = server)

Friendly Tips

When adding a working example, make sure it is reproducible. For instance, I don't have access to the folder /Users/Ben/Documents/Masters/Stats/Shiny/v8/www/, so I had to modify your code to make it work. If it takes us some time to understand/correct your code, it will take longer for you to get an answer.

More info on this can be found here: How to make a great R reproducible example?

Other than that, welcome to SO. =)

ogustavo
  • 546
  • 4
  • 12