我想在一个闪亮的应用程序中放置一个颜色选择器作为一个列类型的rhandontable.使用colourpicker包中的colourInput(),我可以添加颜色选择器作为独立输入,从
HTML标签创建,或将它们放在
HTML表(见下面的示例代码).是否可以添加颜色选择器输入控件到rhandsontable列？
最终目标是允许用户从电子表格(如MS Excel)复制数据并粘贴到rhandontable对象中的应用程序,包括指定颜色名称或十六进制代码的文本.用户可以通过覆盖文本或通过光标操作从选择器中选择颜色来编辑颜色.该应用程序后来将采用这些输入,执行计算,并以指定的颜色绘制图形.
以下是一些示例代码,显示两次尝试失败.任何建议将不胜感激.另外我也不了解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,function(i) {
paste0(
'<div class="form-group shiny-input-container"
data-shiny-input-type="colour">
<input id="myColour','" 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:"),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"),HTML("Success,but this is not a rhandsontable"),uIoUtput("tableWithColourInput")
)
)
))
server <- shinyServer(function(input,output) {
#create DF2 for attempt #2
DF2 <- transform(DF,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)
解决方法
这完全不是一个答案,但我相当确定你不能在一个可以直接使用的内容中使用闪光的输入(可以在datatable里面看到
this).
这里有一些代码可以让输入渲染：
library(shiny); library(rhandsontable); library(colourpicker)
DF <- data.frame(Value = 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文档,您将看到一个类型的参数,它只有几个选项.我相信你只能使用这些可以直接输入的输入.
也许我错了,但我不认为你可以在一个可以控制的内容中渲染一个闪亮的输入.
编辑：
经过一番思考,我相信这是可能的,但它需要很多的javascript.您必须基本上写一个渲染器功能,从头重新创建闪亮的输入.也许在闪亮的JavaScript代码中有一个功能来做到这一点,但我并不是所有的熟悉闪亮的JS内部.
edit2：我试图写一个渲染器的功能,但它似乎还不行.我的猜测是这是不可能的：
library(shiny); library(rhandsontable); library(colourpicker)
DF <- data.frame(Value = 1:4,Colour = 1:4
}),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,server=server)
