In Shiny need to dynamically update dropdown choices with updateRadioGroupButtons

Question

Following R Shiny group buttons with individual hover dropdown selection, need to update the radiogroupbuttons dynamically based on some condition. The number of buttons may change.
I have at least the following queries related to the code below. 1) Does the tag belong in server? 2) how to dynamically multiply selectInput in the server code? 3) How to dynamically multiply the output? I have changed your implementation to fit closer to my application. All dropdowns have the same choices if the button is to be shown a dropdown, this is computed dynamically in dropdownTRUE. If dropdownTRUE==F, I don't need a dropdown.

library(shiny)
library(shinyWidgets)

js <- "
function qTip() {
  $('#THE_INPUT_ID .radiobtn').each(function(i, $el){
    var value = $(this).find('input[type=radio]').val();
    var selector = '#select' + value;
    $(this).qtip({
      overwrite: true,
      content: {
        text: $(selector).parent().parent()
      },
      position: {
        my: 'top left',
        at: 'bottom right'
      },
      show: {
        ready: false
      },
      hide: {
        event: 'unfocus'
      },
      style: {
        classes: 'qtip-blue qtip-rounded'
      },
      events: {
        blur: function(event, api) {
          api.elements.tooltip.hide();
        }
      }
    });
  });
}
function qTip_delayed(x){
  setTimeout(function(){qTip();}, 500);
}
$(document).on('shiny:connected', function(){
  Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"

ui <- fluidPage(
  
  tags$head( # does this belong to server?
    tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
    tags$script(src = "jquery.qtip.min.js"),
    tags$script(HTML(js))
  ),
  
  br(),
  
 uiOutput('bttns'),
 verbatimTextOutput("selection1")
)

server <- function(input, output, session) {
  
  session$sendCustomMessage("qTip", "")
  
  output$bttns<-renderUI({
    bttnchoices=c("A", "B", "C")
    lenchoice=length(bttnchoices)
    dropdownTRUE=sample(c(T,F),lenchoice,T,rep(.5,2)) ##bttns for which dropdown is to be shown
    dropchoices = c("Apple", "Banana")# same choices to be shown for all buttons with dropdownTRUE
    radioGroupButtons(
      inputId = "THE_INPUT_ID",
      individual = TRUE,
      label = "Make a choice: ",
      choices = bttnchoices
    )
    
    div(
      style = "display: none;",
      shinyInput(lenchoice,selectInput, # struggling with dynamic multiplication of selectInput, lapply?
        "select",
        label = "Select a fruit",
        choices=dropchoices,
        selectize = FALSE
      ))
    
  })

  observeEvent(input[["select1"]], {
    if(input[["select1"]] == "Banana"){
      
      session$sendCustomMessage("qTip", "")
      output$bttns<-renderUI({
        bttnchoices=c("D", "A")
        lenchoice=length(bttnchoices)
        dropdownTRUE=sample(c(T,F),lenchoice,T,rep(.5,2)) 
        dropchoices = c("Peach", "Pear") 
        radioGroupButtons(
          inputId = "THE_INPUT_ID",
          individual = TRUE,
          label = "Make a choice: ",
          choices = bttnchoices
        )
        
        div(
          style = "display: none;",
          shinyInput(lenchoice,selectInput,
                     "select",
                     label = "Select a fruit",
                     choices = dropchoices,
                     selectize = FALSE
          ))
        
      })
    }
    output$selection1<-input$select1 # struggling with dynamic multiplication of outputs, lapply?
  })
}
  
  shinyApp(ui, server)

Stéphane Laurent · Accepted Answer · 2020-08-14T10:28:25.263

Here is the way. The values of the radio buttons must correspond to the suffixes of the selectInput's ids. Here A, B, C, D are the values and then the ids of the selectInput are selectA, selectB, selectC, selectD. If you want to use other names for the radio buttons, do choices = list("name1" = "A", "name2" = "B", "name3" = "C", "name4" = "D").

library(shiny)
library(shinyWidgets)

js <- "
function qTip() {
  $('#THE_INPUT_ID .radiobtn').each(function(i, $el){
    var value = $(this).find('input[type=radio]').val();
    var selector = '#select' + value;
    $(this).qtip({
      overwrite: true,
      content: {
        text: $(selector).parent().parent()
      },
      position: {
        my: 'top left',
        at: 'bottom right'
      },
      show: {
        ready: false
      },
      hide: {
        event: 'unfocus'
      },
      style: {
        classes: 'qtip-blue qtip-rounded'
      },
      events: {
        blur: function(event, api) {
          api.elements.tooltip.hide();
        }
      }
    });
  });
}
function qTip_delayed(x){
  setTimeout(function(){qTip();}, 500);
}
$(document).on('shiny:connected', function(){
  Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"

ui <- fluidPage(

  tags$head(
    tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
    tags$script(src = "jquery.qtip.min.js"),
    tags$script(HTML(js))
  ),

  br(),

  radioGroupButtons(
    inputId = "THE_INPUT_ID",
    individual = TRUE,
    label = "Make a choice: ",
    choices = c("A", "B", "C")
  ),

  br(), br(), br(),
  verbatimTextOutput("selectionA"),
  verbatimTextOutput("selectionB"),
  verbatimTextOutput("selectionC"),
  verbatimTextOutput("selectionD"),

  div(
    style = "display: none;",
    selectInput(
      "selectA",
      label = "Select a fruit",
      choices = c("Apple", "Banana"),
      selectize = FALSE
    ),
    selectInput(
      "selectB",
      label = "Select a fruit",
      choices = c("Lemon", "Orange"),
      selectize = FALSE
    ),
    selectInput(
      "selectC",
      label = "Select a fruit",
      choices = c("Strawberry", "Pineapple"),
      selectize = FALSE
    ),
    selectInput(
      "selectD",
      label = "Select a fruit",
      choices = c("Pear", "Peach"),
      selectize = FALSE
    )
  )

)

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

  session$sendCustomMessage("qTip", "")

  output[["selectionA"]] <- renderPrint(input[["selectA"]])
  output[["selectionB"]] <- renderPrint(input[["selectB"]])
  output[["selectionC"]] <- renderPrint(input[["selectC"]])
  output[["selectionD"]] <- renderPrint(input[["selectD"]])

  observeEvent(input[["selectA"]], {
    if(input[["selectA"]] == "Banana"){
      updateRadioGroupButtons(session, inputId = "THE_INPUT_ID",
                              label = "Make NEW choice: ",
                              choices = c("D","A"))
      session$sendCustomMessage("qTip", "")
    }
  })

}

shinyApp(ui, server)

EDIT

The following way allows to set dropdowns for a chosen list of radio buttons.

library(shiny)
library(shinyWidgets)

js <- "
function qTip(values, ids) {
  $('#THE_INPUT_ID .radiobtn').each(function(i, $el){
    var value = $(this).find('input[type=radio]').val();
    if(values.indexOf(value) > -1){
      var selector = '#' + ids[value];
      $(this).qtip({
        overwrite: true,
        content: {
          text: $(selector).parent().parent()
        },
        position: {
          my: 'top left',
          at: 'bottom right'
        },
        show: {
          ready: false
        },
        hide: {
          event: 'unfocus'
        },
        style: {
          classes: 'qtip-blue qtip-rounded'
        },
        events: {
          blur: function(event, api) {
            api.elements.tooltip.hide();
          }
        }
      });
    }
  });
}
function qTip_delayed(mssg){
  $('[data-hasqtip]').qtip('destroy', true);
  setTimeout(function(){qTip(mssg.values, mssg.ids);}, 500);
}
$(document).on('shiny:connected', function(){
  Shiny.addCustomMessageHandler('qTip', qTip_delayed);
});
"

ui <- fluidPage(

  tags$head(
    tags$link(rel = "stylesheet", href = "jquery.qtip.min.css"),
    tags$script(src = "jquery.qtip.min.js"),
    tags$script(HTML(js))
  ),

  br(),

  radioGroupButtons(
    inputId = "THE_INPUT_ID",
    individual = TRUE,
    label = "Make a choice: ",
    choices = c("A", "B", "C")
  ),

  br(), br(), br(),
  uiOutput("selections"),

  uiOutput("dropdowns")

)

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

  dropdowns <- reactiveVal(list( # initial dropdowns
    A = c("Apple", "Banana"),
    B = c("Lemon", "Orange"),
    C = c("Strawberry", "Pineapple")
  ))

  flag <- reactiveVal(FALSE)
  prefix <- reactiveVal("")

  observeEvent(dropdowns(), {
    if(flag()) prefix(paste0("x",prefix()))
    flag(TRUE)
  }, priority = 2)

  observeEvent(input[["selectA"]], {
    if(input[["selectA"]] == "Banana"){
      updateRadioGroupButtons(session, inputId = "THE_INPUT_ID",
                              label = "Make NEW choice: ",
                              choices = c("D","A","B"))
      dropdowns( # new dropdowns, only for D and B
        list(
          D = c("Pear", "Peach"),
          B = c("Watermelon", "Mango")
        )
      )
    }
  })

  observeEvent(dropdowns(), {
    req(dropdowns())
    session$sendCustomMessage(
      "qTip",
      list(
        values = as.list(names(dropdowns())),
        ids = setNames(
          as.list(paste0(prefix(), "select", names(dropdowns()))),
          names(dropdowns())
        )
      )
    )
  })

  observeEvent(dropdowns(), {
    req(dropdowns())
    lapply(names(dropdowns()), function(value){
      output[[paste0("selection",value)]] <-
        renderPrint(input[[paste0(prefix(), "select", value)]])
    })
  })

  output[["dropdowns"]] <- renderUI({
    req(dropdowns())
    selectInputs <- lapply(names(dropdowns()), function(value){
      div(style = "display: none;",
          selectInput(
            paste0(prefix(), "select", value),
            label = "Select a fruit",
            choices = dropdowns()[[value]],
            selectize = FALSE
          )
      )
    })
    do.call(tagList, selectInputs)
  })

  output[["selections"]] <- renderUI({
    req(dropdowns())
    verbOutputs <- lapply(names(dropdowns()), function(value){
      verbatimTextOutput(
        paste0("selection", value)
      )
    })
    do.call(tagList, verbOutputs)
  })

}

shinyApp(ui, server)

Thanks for the code. It does work but I didn't state the "dynamic" need clearly. I want to dynamically calculate the choices (D and A) and the corresponding dropdown choices (pear and banana) in the server code. They are not a priori known to place in the UI code. — Rppa, Aug 12 '20 at 19:06
Didn't know how to paste the code in the comment, so I edited the original problem with the code and comments. Please take a look. Thanks! — Rppa, Aug 12 '20 at 23:44
I see that you cleverly used lapply to multiply. Would you be able to recommend any literature to learn shiny and JS? Thanks for the effort you put in this. I hope others benefit from your solution as well. — Rppa, Aug 14 '20 at 12:51
@Rppa There is a couple of books about Shiny (type "shiny book R" on Google). I learned JavaScript very progressively. First, someone showed me the basics of jQuery (which you can use in Shiny). Then I self-learned by doing some stuff for Shiny apps. I searched some help with Google, which often drived me to StackOverflow. I'm still not fluent in JavaScript, but I manage to do what I want, sometimes by copying some code I don't understand. Certainly there are some books or online tutorials on jQuery, I would recommend to start here. jQuery is a JavaScript library which facilitates JavaScript. — Stéphane Laurent, Aug 14 '20 at 13:04
How would I add an actionButton to submit to each hover? I added actionButton right after selectInput in lapply but that didn't work. Is it something very simple or like this link which works but I am trying to understand how:). — Rppa, Aug 17 '20 at 00:24
I am happy that I figured something:) I needed to include the actionButton in div() to make it work. like so div(actionButton(inputId =paste0(prefix(), "submitselect", value),'Submit') ) — Rppa, Aug 17 '20 at 00:58
@Rppa Add such a CSS in `tags$head`: `tags$style(HTML(".qtip {width: 400px;}"))`. — Stéphane Laurent, Aug 17 '20 at 09:47
Whenever I have a blank space in the name of a checkboxgroupbutton, only those buttons with a space show a blank hover. I tried using backticks and quotes around those names and inputIds using those names but that didn't work. I suspect, it might need quotes in JS. choices = c("A A", "B B", "C") — Rppa, Aug 17 '20 at 19:04
@Rppa The names of the initial dropdown list (`# initial dropdown`) must match: `"A A" = c("Apple", "Banana"), ...`. — Stéphane Laurent, Aug 17 '20 at 19:28
I tried many combinations starting with this but it didn't work. dropdowns <- reactiveVal(list( # initial dropdowns "A A" = c("Apple", "Banana"), A = c("Lemon", "Orange"), B = c("Strawberry", "Pineapple") )) — Rppa, Aug 17 '20 at 23:34
Worked with backticks in the list alongwith gsub for input and outputIDs. list( # initial dropdowns `C D` = c("Apple", "Banana"), `A` = c("Lemon", "Orange"), `B` = c("Strawberry", "Pineapple") ) , ids = setNames( as.list(paste0(prefix(), "select", gsub(' |[[:punct:]]','',names(dropdowns())))), names(dropdowns()) ) — Rppa, Aug 18 '20 at 03:21
please , if you could give a hint to arrange the buttons in the code in — Rppa, Aug 24 '20 at 19:10
Is there a way to trigger this with doubleclick on radiogroupbuttons instead of hover? — Rppa, Sep 08 '20 at 18:42

In Shiny need to dynamically update dropdown choices with updateRadioGroupButtons

1 Answers1

EDIT

Linked