Wstawianie wejść sterujących i widżetów HTML w komórkach nadających się do scalania w błyszczącym kolorze

Question

Chciałbym ustawić próbnik kolorów jako typ kolumny wewnątrz aplikacji rhandsontable w aplikacji shiny. Korzystając z pakietu colourInput() z pakietu, mogę dodać selektory kolorów jako autonomiczne dane wejściowe, utworzyć je ze znaczników HTML lub umieścić je w tabelach HTML (zobacz przykładowy kod poniżej). Czy jest możliwe dodanie kontrolek wprowadzania prób kolorów do kolumn rhandsontable?

Celem końcowym jest aplikacja, która pozwala użytkownikom kopiować dane z arkusza kalkulacyjnego, takiego jak MS Excel, i wklejać do obiektu rhandsontable, w tym tekst określający nazwę koloru lub kod szesnastkowy. Użytkownicy mogą edytować kolory, zastępując tekst lub wybierając kolor z selektora za pomocą akcji kursora. Aplikacja będzie później pobierać te dane wejściowe, wykonywać obliczenia i wyświetlać wyniki w określonych kolorach.

Poniżej znajduje się przykładowy kod pokazujący dwie nieudane próby. Każda rada byłaby doceniona. Ponadto nic nie wiem o JavaScript. Winiety colourpicker i rhandsontable to doskonałe zasoby, ale nadal nie mogłem tego rozgryźć.

Minimal przykład

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) 

Rozszerzony przykład z 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

To nie jest dokładnie odpowiedź, ale jestem prawie pewna, że ​​nie można używać błyszczące wejścia wewnątrz urządzenia do pisania (możesz wejść do wnętrza da tatable zobacz this).

Oto kod, który pobiera dane wejściowe do renderowania:

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) 

Problem jest, że element <input> wewnątrz colourInput zamienia się handsontable wejścia co zapobiega błyszczącą kodu JS od przekształcając go w błyszczące wejścia.

Jeśli spojrzysz na dokumentację hot_col, zobaczysz parametr typu, który ma tylko kilka opcji. Sądzę, że można używać tylko tych wejść do wprowadzania w tryb ręczny.

Być może jestem w błędzie, ale nie sądzę, że można renderować błyszczące dane wejściowe wewnątrz zestawu do ręcznego ustawiania.

edytuj: Po pewnym myśleniu uważam, że jest to możliwe, ale wymagałoby to dużej ilości javascriptu. Musiałbyś zasadniczo napisać funkcję renderera, która odtworzyła błyszczące dane wejściowe od zera. Być może w błyszczącym kodzie javascript istnieje funkcja, aby to zrobić, ale nie jestem zaznajomiony z wewnętrznymi obiektami JS.

edit2: Próbowałem napisać funkcję renderera, ale nadal nie działa. Zgaduję, że nie jest to możliwe:

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)