Inserting control inputs and HTML widgets inside rhandsontable cells in shiny

Question

I'd like to put a colour picker as a column type inside a rhandsontable in a shiny app. Using colourInput() from the colourpicker package, I can add colour pickers as stand-alone inputs, create them from HTML tags, or put them in HTML tables (see example code below). Is it possible to add colour picker input controls to rhandsontable columns?

The end goal is an application that allows users to copy data from a spreadsheet like MS Excel and paste into the rhandsontable object, including text specifying the color name or Hex code. Users can edit colours by overwriting text or selecting a color from the picker via cursor action. The app would later take those inputs, perform calculations, and graph results in the specified colors.

Below is some sample code showing two failed attempts. Any advice would be appreciated. Also, I know nothing about JavaScript. The colourpicker and rhandsontable vignettes are excellent resources, but I still couldn't figure it out.

Minimal example

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)

Extended example with screengrab:

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

This isn't an answer exactly, but I am fairly certain you cannot use shiny inputs inside of a handsontable (you can inside a datatable see this).

Here is some code that gets the input to render:

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)

Issue is that the <input> element inside of the colourInput turns into a handsontable input which prevents shiny JS code from turning it into a shiny input.

If you look at the hot_col documentation you will see a parameter for type, which only has a few options. I believe you can only use those handsontable inputs.

Perhaps I am wrong, but I don't think you can render a shiny input inside a handsontable.

edit: After some thinking I believe it is possible, but it would require a lot of javascript. You'd have to essentially write a renderer function that recreated the shiny input from scratch. Maybe in the shiny javascript code there is a function to do this, but I am not all that familiar with shiny's JS internals.

edit2: I tried to write a renderer function, but it still seems to not work. My guess is this isn't possible:

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)