这是工作代码的示例。这个想法是有一个数据表输出,用户可以在其中调整绘制点的颜色;会话期间颜色应保持变化;颜色作为不同输出的输入。它适用于十六进制字符串,但我想切换到颜色选择而不是十六进制值。
library(shiny)
library(DT)
library(ggplot2)
ui <- fluidPage(
DTOutput("table"),
plotOutput("plot")
)
server <- function(input, output, session) {
mdf <- data.frame(
station = c("Station 1", "Station 2", "Station 3"),
color = c("#1f77b4", "#ff7f0e", "#d62728"),
value = c(1, 2, 3)
)
meta <- reactiveValues(data = mdf)
proxy <- dataTableProxy("table")
observeEvent(input$table_cell_edit, {
info <- input$table_cell_edit
i <- info$row
j <- info$col + 1
k <- info$value
isolate({
meta$data[i, j] <- k
})
replaceData(proxy, meta$data, resetPaging = FALSE)
})
observe({
print(meta$data$color)
})
output$table <- renderDT({
datatable(
meta$data,
editable = TRUE,
rownames = FALSE
)
})
output$plot <- renderPlot({
ggplot(meta$data, aes(x = station, y = value)) +
geom_point(aes(color = station), size = 5) +
scale_color_manual(values = meta$data$color)
})
}
shinyApp(ui, server)
我尝试过使用colourpicker和shinyWidgets,但都没有成功:颜色在DT中视觉上发生了变化,但作为编辑事件似乎没有给观察者留下深刻的印象...
这是我的一项试验的 Reprex,其中十六进制值被颜色选择器替换,但在调整时不更新反应性“元”。
library(shiny)
library(DT)
library(ggplot2)
library(shinyWidgets)
ui <- fluidPage(
DTOutput("table"),
plotOutput("plot")
)
server <- function(input, output, session) {
mdf <- data.frame(
station = c("Station 1", "Station 2", "Station 3"),
color = c("#1f77b4", "#ff7f0e", "#d62728"),
value = c(1, 2, 3)
)
meta <- reactiveValues(data = mdf)
proxy <- dataTableProxy("table")
observeEvent(input$table_cell_edit, {
info <- input$table_cell_edit
i <- info$row
j <- info$col + 1
k <- info$value
isolate({
meta$data[i, j] <- k
})
replaceData(proxy, meta$data, resetPaging = FALSE)
})
observe({
print(meta$data$color)
})
output$table <- renderDT({
datatable(
meta$data,
editable = TRUE,
rownames = FALSE,
escape = FALSE,
options = list(
columnDefs = list(
list(targets = 1, render = JS(
"function(data, type, row, meta) {",
"return '<input type=\"color\" value=\"' + data + '\">';",
"}")
)
)
)
)
})
output$plot <- renderPlot({
ggplot(meta$data, aes(x = station, y = value)) +
geom_point(aes(color = station), size = 5) +
scale_color_manual(values = meta$data$color)
})
}
shinyApp(ui, server)
你可以使用rhandsontable
library(shiny)
library(rhandsontable)
library(colourpicker)
ui <- fluidPage(
rHandsontableOutput("hot"),
plotOutput("plot")
)
server <- function(input, output, session) {
mdf <- data.frame(
station = c("Station 1", "Station 2", "Station 3"),
Color = c("#1f77b4", "#ff7f0e", "#d62728"), # Default colors
value = c(1, 2, 3),
stringsAsFactors = FALSE
)
meta <- reactiveValues(data = mdf)
output$hot <- renderRHandsontable({
req(meta$data)
rhandsontable(meta$data,rowHeaders = NULL) %>%
hot_col("Color", renderer = "
function(instance, td, row, col, prop, value, cellProperties) {
Handsontable.renderers.TextRenderer.apply(this, arguments);
var colorPicker = document.createElement('input');
colorPicker.type = 'color';
colorPicker.value = value;
colorPicker.style.width = '100%';
colorPicker.style.border = 'none';
colorPicker.oninput = function() {
td.style.backgroundColor = this.value;
Shiny.setInputValue('color_clicked', {row: row, color: this.value}, {priority: 'event'});
};
td.innerHTML = '';
td.appendChild(colorPicker);
td.style.backgroundColor = value;
}",
editor = "text")
})
observeEvent(input$color_clicked, {
meta$data$Color[input$color_clicked$row+1] <- input$color_clicked$color
})
output$plot <- renderPlot({
ggplot(meta$data, aes(x = station , y = value)) +
geom_point(aes(color = station), size = 5) +
scale_color_manual(values = meta$data$Color)
})
}
shinyApp(ui = ui, server = server)