在闪亮的 rhandsontable 单元格中插入控制输入和 HTML 小部件
Inserting control inputs and HTML widgets inside rhandsontable cells in shiny
我想在 shiny 应用程序的 rhandsontable 中将颜色选择器作为列类型。使用 colourpicker 包中的 colourInput()，我可以将颜色选择器添加为独立输入，从 HTML 标签创建它们，或者将它们放入 HTML 表中（参见示例代码以下）。是否可以将颜色选择器输入控件添加到 rhandsontable 列？
最终目标是一个允许用户从 MS Excel 等电子表格中复制数据并粘贴到 rhandsontable 对象中的应用程序，包括指定颜色名称或十六进制代码的文本。用户可以通过覆盖文本或通过光标操作从选择器中选择颜色来编辑颜色。该应用稍后会采用这些输入、执行计算并以指定颜色绘制结果图表。
下面是一些示例代码，显示了两次失败的尝试。任何意见，将不胜感激。另外，我对JavaScript一无所知。 colourpicker and 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)
这不是一个确切的答案，但我相当肯定你不能在 handsontable 中使用闪亮的输入（你可以在数据表中看到 ）。
下面是获取渲染输入的一些代码：
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 代码将其变成闪亮的输入。
如果您查看 hot_col 文档，您会看到一个类型参数，它只有几个选项。我相信你只能使用那些可以动手的输入。
也许我错了，但我认为您无法在手持设备中呈现闪亮的输入。
编辑：
经过一番思考，我认为这是可能的，但这需要很多 javascript。您基本上必须编写一个渲染器函数，从头开始重新创建闪亮的输入。也许在 shiny javascript 代码中有一个函数可以做到这一点，但我对 shiny 的 JS 内部结构不是很熟悉。
edit2: 我试着写了一个renderer函数，但是好像还是不行。我猜这是不可能的：
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)
我想在 shiny 应用程序的 rhandsontable 中将颜色选择器作为列类型。使用 colourpicker 包中的 colourInput()，我可以将颜色选择器添加为独立输入，从 HTML 标签创建它们，或者将它们放入 HTML 表中（参见示例代码以下）。是否可以将颜色选择器输入控件添加到 rhandsontable 列？
最终目标是一个允许用户从 MS Excel 等电子表格中复制数据并粘贴到 rhandsontable 对象中的应用程序，包括指定颜色名称或十六进制代码的文本。用户可以通过覆盖文本或通过光标操作从选择器中选择颜色来编辑颜色。该应用稍后会采用这些输入、执行计算并以指定颜色绘制结果图表。
下面是一些示例代码，显示了两次失败的尝试。任何意见，将不胜感激。另外，我对JavaScript一无所知。 colourpicker and 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)
这不是一个确切的答案，但我相当肯定你不能在 handsontable 中使用闪亮的输入（你可以在数据表中看到
下面是获取渲染输入的一些代码：
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 代码将其变成闪亮的输入。
如果您查看 hot_col 文档，您会看到一个类型参数，它只有几个选项。我相信你只能使用那些可以动手的输入。
也许我错了，但我认为您无法在手持设备中呈现闪亮的输入。
编辑： 经过一番思考，我认为这是可能的，但这需要很多 javascript。您基本上必须编写一个渲染器函数，从头开始重新创建闪亮的输入。也许在 shiny javascript 代码中有一个函数可以做到这一点，但我对 shiny 的 JS 内部结构不是很熟悉。
edit2: 我试着写了一个renderer函数，但是好像还是不行。我猜这是不可能的：
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)