光沢のある頑丈なセルにコントロール入力とHTMLウィジェットを挿入する

Question

shinyアプリのrhandsontableの内部にカラータイプとしてカラーピッカーを配置したいと思います。 colourpickerパッケージのcolourInput()を使用して、カラーピッカーをスタンドアロン入力として追加したり、HTMLタグから作成したり、HTMLテーブルに配置することができます（下記のサンプルコードを参照）。カラーピッカー入力コントロールをrhandsontable列に追加することはできますか？

最終目標は、MS Excelなどのスプレッドシートからデータをコピーして、rhandsontableオブジェクトに貼り付けるアプリケーションです。これには、色名または16進コードを指定するテキストも含まれます。ユーザーは、テキストを上書きするか、カーソル操作でピッカーから色を選択して色を編集できます。アプリケーションは、後でそれらの入力を受け取り、計算を実行し、指定された色で結果をグラフ化する。

以下は、失敗した2回の試行を示すサンプルコードです。アドバイスをいただければ幸いです。また、私は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) 

の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

これはまさに答えではないですが、私はあなたが使用することはできませんかなり確信しています手錠の中の光沢のある入力（あなたはdaの中に入ることができますテーブル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) 

問題はcolourInputの内部<input>要素は光沢のある入力にそれを回すから光沢JSコードを防止handsontable入力になることです。

hot_colのドキュメントを見ると、いくつかのオプションしかないタイプのパラメータが表示されます。私はあなたがそれらの手の届かない入力だけを使うことができると信じています。

おそらく私は間違っていますが、あなたは手錠の中に光沢のある入力を与えることはできないと思います。

編集： 私はそれが可能だと思っていくつか考えた後、それは多くのJavaScriptが必要になります。光沢のある入力を最初から作り直したレンダラー関数を書く必要があります。おそらく光沢のあるJavaScriptコードにはこれを行う関数がありますが、私は光沢のある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)