Вставка управляющих входов и виджетов HTML внутри несущественных ячеек в блестящих
Я хотел бы поместить элемент выбора цвета в виде столбца внутри 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)
Расширенный пример с помощью 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)
![введите описание изображения здесь]()
Ответы
Ответ 1
Это не ответ точно, но я уверен, что вы не можете использовать блестящие входы внутри handsontable (вы можете внутри datatable видеть 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 превращается в удобный для пользователя ввод, который не позволяет блестящему JS-коду превратить его в блестящий вход.
Если вы посмотрите на документацию hot_col, вы увидите параметр для типа, который имеет только несколько параметров. Я считаю, что вы можете использовать только эти удобные входы.
Возможно, я ошибаюсь, но я не думаю, что вы можете сделать блестящий ввод внутри handsontable.
изменить:
После некоторых размышлений я считаю, что это возможно, но для этого потребуется много 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)
