[英]Complex R Shiny input binding issue with datatable
I am trying to do something a little bit tricky and I am hoping that someone can help me. 我想做一些有点棘手的事情,我希望有人可以帮助我。
I would like to add selectInput
inside a datatable. 我想在数据表中添加
selectInput
。 If I launch the app, I see that the inputs col_1
, col_2
.. are well connected to the datatable (you can switch to a, b or c) 如果我启动应用程序,我会看到输入
col_1
, col_2
..已连接到数据表(您可以切换到a,b或c)
BUT If I update the dataset (from iris
to mtcars
) the connection is lost between the inputs and the datatable. 但是如果我更新数据集(从
iris
到mtcars
),输入和数据表之间的连接就会丢失。 Now if you change a selectinput
the log doen't show the modification. 现在,如果更改
selectinput
则日志不会显示修改。 How can I keep the links? 我该如何保留链接?
I made some test using shiny.bindAll()
and shiny.unbindAll()
without success. 我使用
shiny.bindAll()
和shiny.unbindAll()
做了一些测试但没有成功。
Any Ideas? 有任何想法吗?
Please have a look at the app: 请看看该应用程序:
library(shiny)
library(DT)
library(shinyjs)
library(purrr)
ui <- fluidPage(
selectInput("data","choose data",choices = c("iris","mtcars")),
DT::DTOutput("tableau"),
verbatimTextOutput("log")
)
server <- function(input, output, session) {
dataset <- reactive({
switch (input$data,
"iris" = iris,
"mtcars" = mtcars
)
})
output$tableau <- DT::renderDT({
col_names<-
seq_along(dataset()) %>%
map(~selectInput(
inputId = paste0("col_",.x),
label = NULL,
choices = c("a","b","c"))) %>%
map(as.character)
DT::datatable(dataset(),
options = list(ordering = FALSE,
preDrawCallback = JS("function() {
Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());
}")
),
colnames = col_names,
escape = FALSE
)
})
output$log <- renderPrint({
lst <- reactiveValuesToList(input)
lst[order(names(lst))]
})
}
shinyApp(ui, server)
Understanding your challenge: 了解您的挑战:
In order to identify your challenge at hand you have to know two things. 为了确定您手头的挑战,您必须了解两件事。
selectInput()
is just a wrapper for html code. selectInput()
只是html代码的包装器。 If you type selectInput("a", "b", "c")
in the console it will return: 如果在控制台中键入
selectInput("a", "b", "c")
,它将返回:
<div class="form-group shiny-input-container">
<label class="control-label" for="a">b</label>
<div>
<select id="a"><option value="c" selected>c</option></select>
<script type="application/json" data-for="a" data-nonempty="">{}</script>
</div>
</div>
Note that you are building <select id="a">
, a select with id="a"
. 请注意,您正在构建
<select id="a">
,一个id="a"
的选择。 So if we assume 1) is correct after refresh you attempt to build another html element : <select id="a">
with an existing id. 因此,如果我们假设1)在刷新后是正确的,则尝试构建另一个html元素:
<select id="a">
具有现有id。 That is not supposed to work: Can multiple different HTML elements have the same ID if they're different elements? 这不应该工作: 如果多个不同的HTML元素是不同的元素,它们可以具有相同的ID吗? .
。 (Assuming my assumption 1) holds true ;))
(假设我的假设1)成立;))
Solving your challenge: 解决您的挑战:
On first sight pretty simple: Just ensure the id you use is unique within the created html document. 乍一看很简单:只需确保您使用的ID在创建的html文档中是唯一的。
The very quick and dirty way would be to replace: 非常快速和肮脏的方式将取代:
inputId = paste0("col_",.x)
with something like: inputId = paste0("col_", 1:nc, "-", sample(1:9999, nc))
. 例如:
inputId = paste0("col_", 1:nc, "-", sample(1:9999, nc))
。
But that would be difficult to use afterwards for you. 但是之后很难用到你身上。
Longer way: 更长的方式:
So you could use some kind of memory 所以你可以使用某种记忆
You can use 您可以使用
global <- reactiveValues(oldId = c(), currentId = c())
for that. 为了那个原因。
An idea to filter out the old used ids and to extract the current ones could be this: 过滤掉旧的使用ID并提取当前ID的想法可能是这样的:
lst <- reactiveValuesToList(input)
lst <- lst[setdiff(names(lst), global$oldId)]
inp <- grepl("col_", names(lst))
names(lst)[inp] <- sapply(sapply(names(lst)[inp], strsplit, "-"), "[", 1)
Reproducible example would read: 可重复的示例如下:
library(shiny)
library(DT)
library(shinyjs)
library(purrr)
ui <- fluidPage(
selectInput("data","choose data",choices = c("iris","mtcars")),
dataTableOutput("tableau"),
verbatimTextOutput("log")
)
server <- function(input, output, session) {
global <- reactiveValues(oldId = c(), currentId = c())
dataset <- reactive({
switch (input$data,
"iris" = iris,
"mtcars" = mtcars
)
})
output$tableau <- renderDataTable({
isolate({
global$oldId <- c(global$oldId, global$currentId)
nc <- ncol(dataset())
global$currentId <- paste0("col_", 1:nc, "-", sample(setdiff(1:9999, global$oldId), nc))
col_names <-
seq_along(dataset()) %>%
map(~selectInput(
inputId = global$currentId[.x],
label = NULL,
choices = c("a","b","c"))) %>%
map(as.character)
})
DT::datatable(dataset(),
options = list(ordering = FALSE,
preDrawCallback = JS("function() {
Shiny.unbindAll(this.api().table().node()); }"),
drawCallback = JS("function() { Shiny.bindAll(this.api().table().node());
}")
),
colnames = col_names,
escape = FALSE
)
})
output$log <- renderPrint({
lst <- reactiveValuesToList(input)
lst <- lst[setdiff(names(lst), global$oldId)]
inp <- grepl("col_", names(lst))
names(lst)[inp] <- sapply(sapply(names(lst)[inp], strsplit, "-"), "[", 1)
lst[order(names(lst))]
})
}
shinyApp(ui, server)
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.