Radiobuttons in Shiny DataTable for “subselection” of rows/ grouping in one column

问题

What I am trying to accomplish is similar to this thread, but slightly more complicated.

I would like to group the radio buttons into different groups, but in one column so a "subselection" of rows is possible.

Currently only the radio button group with ID "C" works, because the div element is defined for the whole table. I have tried to insert the shiny tags via javascript callback, but I'm only able to insert a radio button for each row or for each column, but not for a subset of multiple rows in one column.

Open to javascript or shiny solutions.

shinyApp(
  ui = fluidPage(
    title = 'Radio buttons in a table',
    tags$div(id="C",class='shiny-input-radiogroup',DT::dataTableOutput('foo')),
    verbatimTextOutput("test")
  ),
  server = function(input, output, session) {
    m = matrix(
      c(round(rnorm(24),1), rep(3,12)), nrow = 12, ncol = 3, byrow = F,
      dimnames = list(month.abb, LETTERS[1:3])
    )
    m[, 2] <- rep(c("A","B","C", "D"), each= 3)
    m[, 3] <- paste0('<input type="radio" name="', rep(c("A","B","C", "D"), each= 3),'" value="', month.abb,'"/>')
    m[c(1,4,7,10), 3] <- gsub('/>', 'checked="checked"/>', m[c(1,4,7,10), 3], fixed = T)
    m
    output$foo = DT::renderDataTable(
      m, escape = FALSE, selection = 'none', server = FALSE,
      options = list(dom = 't', paging = FALSE, ordering = FALSE)
      # callback = JS("table.rows().every(function() {
      #           var $this = $(this.node());
      #           $this.attr('id', this.data()[0]);
      #           $this.addClass('shiny-input-radiogroup');
      #           });
      #           Shiny.unbindAll(table.table().node());
      #           Shiny.bindAll(table.table().node());")
    )
    output$test <- renderPrint(str(input$C))
  }
)

UPDATE:

The rough structure of my final solution with reactive button selection. The inputs and visuals stay preserved with re-rendering the table (just the first time the input renders as NULL which is no particular problem for me).

library(shiny)
library(DT)

shinyApp(
  ui = fluidPage(
    title = "Radio buttons in a table",
    sliderInput("slider_num_rows", "Num Rows", min = 2, max = 12, value = 5),
    tags$div(id = 'placeholder'),
    verbatimTextOutput("test")
  ),
  server = function(input, output, session) {
    rea <- reactive({
      m = matrix(
        c(round(rnorm(24),1), rep(3,12)), nrow = 12, ncol = 3, byrow = F,
        dimnames = list(month.abb, LETTERS[1:3])
      )

      m[, 2] <- rep(c("A","B","C", "D"), each= 3)
      m[, 3] <- paste0('<input type="radio" name="', rep(c("A","B","C", "D"), each= 3),'" value="', month.abb,'"/>')
      save_sel <- c()
      mon_tes <- c("Jan", "Apr", "Jul", "Oct")
      ab <- c("A", "B", "C", "D")
      for (i in 1:4){
        if (is.null(input[[ab[i]]])){
          save_sel[i] <-  mon_tes[i]
        } else {
          save_sel[i] <- input[[ab[i]]]
        }
      }
      sel <- rownames(m) %in% save_sel
      m[sel, 3] <- gsub('/>', 'checked="checked"/>', m[sel, 3], fixed = T)
      m <- m[1:input$slider_num_rows,]
      m
    })

    output$foo = DT::renderDataTable(
      rea(), escape = FALSE, selection = 'none', server = FALSE,
      options = list(dom = 't', paging = FALSE, ordering = FALSE,
                     columnDefs = list(list(className = 'no_select', targets = 3)))
    )

     observe({
      l <- unique(m[, 2])

      for(i in 1:length(l)) {
        if (i == 1) {
          radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))
        } else {
          radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", radio_grp)
        }
      }
      insertUI(selector = '#placeholder',
               ui = radio_grp)
    })
    output$test <- renderPrint( {
      str(input$A)
      str(input$B)
      str(input$C)
      str(input$D)
    })
  }
)

回答1:

You can nest the div elements into each other like this:

  ui = fluidPage(
    title = "Radio buttons in a table",
    div(id = "A", class = "shiny-input-radiogroup",
      div(id = "B", class = "shiny-input-radiogroup",
        div(id = "C", class = "shiny-input-radiogroup",
          div(id = "D", class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))    
        )
      )
    ),

I also modified renderText in order to print all the values.

output$test <- renderPrint( {
  str(input$A)
  str(input$B)
  str(input$C)
  str(input$D)
})

Here is the result after interacting with the dataTableOutput (selected the Feb radio button):

Please note that the elements will still have NULL value until interaction. You can get around this problem though, with an if statement, using the default values of radio buttons when the input elements are NULL.

Edit: You can create the divs with a loop like this:

l <- unique(m[, 2])

for(i in 1:length(l)) {
  if (i == 1) {
    radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", DT::dataTableOutput("foo"))
  } else {
    radio_grp <- div(id = l[i], class = "shiny-input-radiogroup", radio_grp) 
  }
}

来源：https://stackoverflow.com/questions/47886003/radiobuttons-in-shiny-datatable-for-subselection-of-rows-grouping-in-one-colu

标签

javascript

Shiny