r - 在 Shiny 的 rhandsontable 单元格中插入控制输入和 HTML 小部件

Question

我想将颜色选择器作为列类型放在 rhandsontable 应用程序中的 shiny 中。使用 colourInput() 包中的 colourpicker，我可以添加颜色选择器作为独立输入，从 HTML 标签创建它们，或将它们放在 HTML 表中(参见下面的示例代码)。是否可以将颜色选择器输入控件添加到 rhandsontable 列？

最终目标是一个应用程序，它允许用户从像 MS Excel 这样的电子表格复制数据并粘贴到 rhandsontable 对象中，包括指定颜色名称或十六进制代码的文本。用户可以通过覆盖文本或通过光标操作从选择器中选择颜色来编辑颜色。该应用程序稍后将接受这些输入，执行计算，并以指定的颜色绘制结果。

下面是一些示例代码，显示了两次失败的尝试。任何意见，将不胜感激。另外，我对 JavaScript 一无所知。 colourpicker 和 rhandsontable 小插曲是极好的资源，但我仍然无法弄清楚。

最小示例

library(shiny); library(rhandsontable); library(colourpicker)

hotDF <- data.frame(Value = 1:4, Status = TRUE, Name = LETTERS[1:4],
                    Date = seq(from = Sys.Date(), by = "days", length.out = 4),
                    Colour = sapply(1:4, function(i) {
                      paste0(
                      '<div class="form-group shiny-input-container" 
                          data-shiny-input-type="colour">
                      <input id="myColour',i,'" type="text" 
                      class="form-control shiny-colour-input" data-init-value="#FFFFFF"
                      data-show-colour="both" data-palette="square"/>
                        </div>'
                      )}), stringsAsFactors = FALSE) 

testColourInput <- function(DF){
  ui <- shinyUI(fluidPage( rHandsontableOutput("hot") ))   
  server <- shinyServer(function(input, output) {

    DF2 <- transform(DF, Colour =  c(sapply(1:4, function(x) {
      jsonlite::toJSON(list(value = "black"))
    })))    #create DF2 for attempt #2

    output$hot <- renderRHandsontable({
      #Attempt #1 = use the HTML renderer
      #Results in no handsontable AND no HTML table <-- why no HTML table too?
      rhandsontable(DF) %>%  hot_col(col = "Colour", renderer = "html")

      #Attempt #2 = use colourWidget
      #Results are the same as above.
      #rhandsontable(DF2) %>% 
      #   hot_col(col = "Colour", renderer = htmlwidgets::JS("colourWidget"))         
    })
  }) #close shinyServer     
  runApp(list(ui=ui, server=server))  
} #close testColorInput function

testColourInput(DF = hotDF)

带有屏幕抓取的扩展示例:

library(shiny); library(rhandsontable); library(colourpicker)

#Colour cells ideally would be a colourInput() control similar to the Date input control
hotDF <- data.frame(Value = 1:4, Status = TRUE, Name = LETTERS[1:4],
                    Date = seq(from = Sys.Date(), by = "days", length.out = 4),
                    Colour = sapply(1:4, function(i) {
                      paste0(
                        '<div class="form-group shiny-input-container" 
                             data-shiny-input-type="colour">
                            <input id="myColour',i,'" type="text" 
                                class="form-control shiny-colour-input" 
                                data-init-value="#FFFFFF" 
                                data-show-colour="both" data-palette="square"/>
                        </div>'
                      )}),
                    stringsAsFactors = FALSE) 

testColourInput <- function(DF){
  ui <- shinyUI(fluidPage(

    sidebarLayout(
      sidebarPanel(
        #Standalone colour Input
        colourInput("myColour", label = "Just the color control:", value = "#000000"),
        br(),
        HTML("Build the colour Input from HTML tags:"), br(),
        HTML(paste0(
          "<div class='form-group shiny-input-container' 
             data-shiny-input-type='colour'>
          <input id='myColour", 999,"' type='text' 
             class='form-control shiny-colour-input' 
             data-init-value='#FFFFFF' data-show-colour='both' 
             data-palette='square'/>
          </div>"

        ))
      ),

      mainPanel(  
        HTML("Failed attempt"),
        rHandsontableOutput("hot"), 
        br(), br(),
        HTML("Success, but this is not a rhandsontable"),
        uiOutput("tableWithColourInput")    
      )
    )
  ))

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

    #create DF2 for attempt #2
    DF2 <- transform(DF, Colour =  c(sapply(1:4, function(x) {
                        jsonlite::toJSON(list(value = "black"))
                    })))

    output$hot <- renderRHandsontable({
      #Attempt #1 = use the HTML renderer
      #Results in no handsontable AND no HTML table <-- why no HTML table too?
      rhandsontable(DF) %>%  hot_col(col = "Colour", renderer = "html")

      #Attempt #2 = use colourWidget
      #Results are the same as above.
      #rhandsontable(DF2) %>% 
      #  hot_col(col = "Colour", renderer = htmlwidgets::JS("colourWidget"))

      #Uncomment below to see the table without html formatting
      #rhandsontable(DF) 
        #^This line was uncommented to obtain the screengrab

    })

    #HTML table
    myHTMLtable <- data.frame(Variable = LETTERS[1:4],
                              Select = NA)

    output$tableWithColourInput <- renderUI({
      #create table cells
      rowz <- list() 
        #Fill out table cells [i,j] with static elements
        for( i in 1:nrow( myHTMLtable )) {
          rowz[[i]] <- tags$tr(lapply( myHTMLtable[i,1:ncol(myHTMLtable)],
                         function( x ) { tags$td( HTML(as.character(x)) ) }
                       ) )
        }
        #Add colourInput() to cells in the "Select" column in myHTMLtable
        for( i in 1:nrow( myHTMLtable ) ) {
          #Note: in the list rowz:
          #  i = row; [3] = row information; children[1] = table cells (list of 1); 
          #  $Select = Column 'Select' 
          rowz[[i]][3]$children[[1]]$Select <- tags$td( 
            colourInput(inputId = as.character(paste0("inputColour", i)), 
                        label = NULL, value = "#000000")
          ) 
        } 
      mybody <- tags$tbody( rowz )

      tags$table( 
        tags$style(HTML(
          ".shiny-html-output th,td {border: 1px solid black;}"
          )),
        tags$thead( 
          tags$tr(lapply( c("Variable!", "Colour!"), function( x ) tags$th(x)))
        ),
        mybody
      ) #close tags$table
    }) #close renderUI

  }) #close shinyServer

  runApp(list(ui=ui, server=server))  
} #close testColorInput function

testColourInput(DF = hotDF)

Answer 1

这不是一个确切的答案，但我相当肯定您不能在手持表中使用 Shiny 的输入(您可以在数据表中查看 this )。

这是一些获取输入以进行渲染的代码:

library(shiny); library(rhandsontable); library(colourpicker)

DF <- data.frame(Value = 1:4, Status = TRUE, Name = LETTERS[1:4],
                    Date = seq(from = Sys.Date(), by = "days", length.out = 4),
                    Colour = sapply(1:4, function(i) {
                      as.character(colourInput(paste0("colour",i),NULL))
                      }), stringsAsFactors = FALSE) 

ui <- shinyUI(fluidPage( rHandsontableOutput("hot"),
                         verbatimTextOutput("test")))   
server <- shinyServer(function(input, output) {

  output$hot <- renderRHandsontable({
    rhandsontable(DF,allowedTags = "<div><input>") %>% 
      hot_col(5, renderer = htmlwidgets::JS("html")) %>%
      hot_col(5, renderer = htmlwidgets::JS("safeHtmlRenderer"))     
  })

  output$test <- renderPrint({
    sapply(1:4, function(i) {
      input[[paste0("colour",i)]]
    })
  })


})

shinyApp(ui=ui,server=server)

问题在于 <input> colourInput 内部的元素变成一个可手动输入的输入，防止 Shiny 的 JS 代码将其变成 Shiny 的输入。

如果你看 hot_col文档您将看到一个类型参数，它只有几个选项。我相信你只能使用那些手动输入。

也许我错了，但我认为您无法在手持台中呈现 Shiny 的输入。

编辑:
经过一番思考，我相信这是可能的，但它需要大量的 javascript。您本质上必须编写一个渲染器函数，从头开始重新创建 Shiny 的输入。也许在 Shiny 的 javascript 代码中有一个函数可以做到这一点，但我对 Shiny 的 JS 内部结构并不十分熟悉。

edit2:我试着写了一个渲染器函数，但似乎还是不行。我的猜测是这是不可能的:

library(shiny); library(rhandsontable); library(colourpicker)

DF <- data.frame(Value = 1:4, Status = TRUE, Name = LETTERS[1:4],
                    Date = seq(from = Sys.Date(), by = "days", length.out = 4),
                    Colour = 1:4
                      }), stringsAsFactors = FALSE) 

ui <- shinyUI(fluidPage( rHandsontableOutput("hot"),
                         verbatimTextOutput("test")))   
server <- shinyServer(function(input, output) {

  output$hot <- renderRHandsontable({
    rhandsontable(DF,allowedTags = "<div><input>") %>% 
      hot_col(5, renderer = htmlwidgets::JS("
        function(instance, td, row, col, prop, value, cellProperties) {

    var y = document.createElement('input');
    y.setAttribute('id','colour'+ value);y.setAttribute('type','text');
    y.setAttribute('class','form-control shiny-colour-input');
    y.setAttribute('data-init-value','#FFFFFF');
    y.setAttribute('data-show-colour','both');
    y.setAttribute('data-palette','square');

    td.appendChild(y);
    return td;
}
                                            "))    
  })

  output$test <- renderPrint({
    sapply(1:4, function(i) {
      input[[paste0("colour",i)]]
    })
  })


})

shinyApp(ui=ui,server=server)