javascript - Shiny 数据表中的单选按钮，用于一列中的 "subselection"行/分组

Question

我想要完成的类似于 this thread , 但稍微复杂一些。

我想将单选按钮分组到不同的组中，但在一列中以便可以对行进行“子选择”。

目前只有 ID 为“C”的单选按钮组有效，因为 div 元素是为整个表格定义的。我试图通过 javascript 回调插入 Shiny 标签，但我只能为每一行或每一列插入一个单选按钮，但不能为一列中多行的子集插入一个单选按钮。

对 javascript 或 Shiny 的解决方案开放。

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))
  }
)

更新:

我最终的响应式按钮选择解决方案的粗略结构。输入和视觉效果在重新呈现表格时保持保留(只是第一次输入呈现为 NULL，这对我来说不是特别的问题)。

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)
    })
  }
)

Answer 1

您可以像这样将 div 元素相互嵌套:

  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"))    
        )
      )
    ),

我还修改了 renderText 以打印所有值。

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

这是与 dataTableOutput 交互后的结果(选择了 Feb 单选按钮):

请注意，元素在交互之前仍将具有 NULL 值。不过，您可以使用 if 语句解决此问题，当输入元素为 NULL 时使用单选按钮的默认值。

编辑:您可以使用如下循环创建div:

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) 
  }
}