Shiny table 中的附加功能
Drop-on functionality in table in Shiny
我正在寻找一种方法(程序包),使我能够 'drop' 从一个 table 在 另一个 [=30] 的一行=].我设想的服务器端功能是我可以创建一些逻辑来更新目标 table。不幸的是,我没有成功地使用我能找到的可用的闪亮包来制作原型。
下面代码中 MVP 概念的想法是将顶部 table 中的其中一个调用者分配(通过 拖放 )到第二行 table.
我得出的结论如下:
library(shiny)
library(shinyjqui)
library(tidyverse)
ui <- fluidPage(
h1("UI functionality: Drop-on table"),
h3("Callers - (source)"),
tableOutput("callers"),
h3("Calls to be made - (destination)"),
tableOutput("calls_to_be_made"),
hr()
)
server <- function(input, output, session) {
callers <- tibble(
Caller = c("Jerry", "Donald")
)
calls_to_be_made <- tibble(
Name = c("John", "Fred", "Bill", "Freddy"),
PhoneNumber = c("0123 456 785", "0123 456 6453", "9876 532 432","235 63 430"),
Caller = c("Jerry",NA,NA,NA )
)
jqui_sortable(
ui = "#callers table",
options = list(items = "tbody tr", connectWith = "#calls_to_be_made table")
)
jqui_sortable(
ui = "#calls_to_be_made table",
options = list(items = "tbody tr")
)
output$callers <- renderTable(callers, rownames = T)
output$calls_to_be_made <- renderTable(calls_to_be_made, rownames = T)
}
shinyApp(ui, server)
我尝试过使用 shinyjqui
函数 jqui_draggable()
和 jqui_droppable()
的解决方案,但这些尝试没有成功,我感觉它们实际上离目标更远草图上方的代码。
我正在寻找创意和建议来实现此功能。希望你们中的一些人读过这个问题会提出在 shiny 中完成这个功能的建议。
您可以使用 {shinyjqui}
创建一个界面,允许您从一些
table,将它们放入不同的 table,并闪亮更新
table 可拖动对象的基础数据框被放入。
首先我们需要在我们的服务器函数中定义我们的 draggable 和 droppable。
jqui_draggable(
ui = "#callers td",
options = list(
revert = "invalid",
helper = "clone"))
droppable <- function() {
jqui_droppable(
ui = "#calls_to_be_made td",
options = list(
drop = JS("function(event, ui) {
Shiny.setInputValue(\"update_cells\", {
source_col: ui.draggable.index(),
source_row: ui.draggable.parent().index() + 1,
dest_col: $(this).index(),
dest_row: $(this).parent().index() + 1
});
}")))
}
droppable() #Initialisation
这里发生了几件事。
首先,
jqui_droppable
调用被封装在一个函数中(droppable
),
因为我们需要稍后再调用它。
其次,我们使用
Shiny.setInputValue()
(javascript 函数)发送行和
已删除的单元格 (source_*
) 和删除的单元格的列索引
被丢弃在 (dest_*
) 到闪亮的后端。 Javascript 索引开始
在 0 和 R 索引在 1,所以我们偏移 JS 的以匹配
内部 R 的。但是,由于行名在
HTML table,但不是在 R 数据框中,我们不需要偏移列索引。
接下来我们让 calls_to_be_made
反应并编写逻辑
更新数据框服务器端。
calls_to_be_made_react <- reactiveVal(calls_to_be_made)
observeEvent(input$update_cells, {
## Update dataset
if (min(unlist(input$update_cells)) > 0) {
updated_ctbm <- calls_to_be_made_react()
## Specify what row and column to drop in
updated_ctbm[
input$update_cells[["dest_row"]],
"Caller"] <- callers[
input$update_cells[["source_row"]],
input$update_cells[["source_col"]]]
calls_to_be_made_react(updated_ctbm)
## Make sure the newly drawn table becomes droppable again
droppable()
}
})
if 语句中的条件检查是否正在拖放行名,并且在拖放时不更新数据框
案件。这种情况可以扩展到某种验证
限制哪些单元格可以被哪个可拖动单元格放置的功能,但这超出了这个问题的范围。
在 observableEvent
里面也是我们称之为 droppable
的地方
再次发挥作用。因为 shiny 重绘了整个 table,所以代码
使得 table 可丢弃也需要再次 运行。
最后我们需要更新输出调用,所以它使用反应式
calls_to_be_made
.
output$calls_to_be_made <- renderTable(calls_to_be_made_react(), rownames = T)
这提供了以下服务器功能,可以满足您的要求。
server <- function(input, output, session) {
callers <- tibble(
Caller = c("Jerry", "Donald")
)
calls_to_be_made <- tibble(
Name = c("John", "Fred", "Bill", "Freddy"),
PhoneNumber = c("0123 456 785", "0123 456 6453", "9876 532 432","235 63 430"),
Caller = c("Jerry",NA,NA,NA )
)
jqui_draggable(
ui = "#callers td",
options = list(
revert = "invalid",
helper = "clone"))
droppable <- function() {
jqui_droppable(
ui = "#calls_to_be_made td",
options = list(
drop = JS("function(event, ui) {
Shiny.setInputValue(\"update_cells\", {
source_col: ui.draggable.index(),
source_row: ui.draggable.parent().index() + 1,
dest_col: $(this).index()
dest_row: $(this).parent().index() + 1
});
}")))
}
droppable() #Initialisation
calls_to_be_made_react <- reactiveVal(calls_to_be_made)
observeEvent(input$update_cells, {
## Update dataset
if (min(unlist(input$update_cells)) > 0) {
updated_ctbm <- calls_to_be_made_react()
## Specify what row and column to drop in
updated_ctbm[
input$update_cells[["dest_row"]],
"Caller"] <- callers[
input$update_cells[["source_row"]],
input$update_cells[["source_col"]]]
calls_to_be_made_react(updated_ctbm)
## Make sure the newly drawn table becomes droppable again
droppable()
}
})
output$callers <- renderTable(callers, rownames = T)
output$calls_to_be_made <- renderTable(calls_to_be_made_react(), rownames = T)
}
我正在寻找一种方法(程序包),使我能够 'drop' 从一个 table 在 另一个 [=30] 的一行=].我设想的服务器端功能是我可以创建一些逻辑来更新目标 table。不幸的是,我没有成功地使用我能找到的可用的闪亮包来制作原型。
下面代码中 MVP 概念的想法是将顶部 table 中的其中一个调用者分配(通过 拖放 )到第二行 table.
我得出的结论如下:
library(shiny)
library(shinyjqui)
library(tidyverse)
ui <- fluidPage(
h1("UI functionality: Drop-on table"),
h3("Callers - (source)"),
tableOutput("callers"),
h3("Calls to be made - (destination)"),
tableOutput("calls_to_be_made"),
hr()
)
server <- function(input, output, session) {
callers <- tibble(
Caller = c("Jerry", "Donald")
)
calls_to_be_made <- tibble(
Name = c("John", "Fred", "Bill", "Freddy"),
PhoneNumber = c("0123 456 785", "0123 456 6453", "9876 532 432","235 63 430"),
Caller = c("Jerry",NA,NA,NA )
)
jqui_sortable(
ui = "#callers table",
options = list(items = "tbody tr", connectWith = "#calls_to_be_made table")
)
jqui_sortable(
ui = "#calls_to_be_made table",
options = list(items = "tbody tr")
)
output$callers <- renderTable(callers, rownames = T)
output$calls_to_be_made <- renderTable(calls_to_be_made, rownames = T)
}
shinyApp(ui, server)
我尝试过使用 shinyjqui
函数 jqui_draggable()
和 jqui_droppable()
的解决方案,但这些尝试没有成功,我感觉它们实际上离目标更远草图上方的代码。
我正在寻找创意和建议来实现此功能。希望你们中的一些人读过这个问题会提出在 shiny 中完成这个功能的建议。
您可以使用 {shinyjqui}
创建一个界面,允许您从一些
table,将它们放入不同的 table,并闪亮更新
table 可拖动对象的基础数据框被放入。
首先我们需要在我们的服务器函数中定义我们的 draggable 和 droppable。
jqui_draggable(
ui = "#callers td",
options = list(
revert = "invalid",
helper = "clone"))
droppable <- function() {
jqui_droppable(
ui = "#calls_to_be_made td",
options = list(
drop = JS("function(event, ui) {
Shiny.setInputValue(\"update_cells\", {
source_col: ui.draggable.index(),
source_row: ui.draggable.parent().index() + 1,
dest_col: $(this).index(),
dest_row: $(this).parent().index() + 1
});
}")))
}
droppable() #Initialisation
这里发生了几件事。
首先,
jqui_droppable
调用被封装在一个函数中(droppable
),
因为我们需要稍后再调用它。
其次,我们使用
Shiny.setInputValue()
(javascript 函数)发送行和
已删除的单元格 (source_*
) 和删除的单元格的列索引
被丢弃在 (dest_*
) 到闪亮的后端。 Javascript 索引开始
在 0 和 R 索引在 1,所以我们偏移 JS 的以匹配
内部 R 的。但是,由于行名在
HTML table,但不是在 R 数据框中,我们不需要偏移列索引。
接下来我们让 calls_to_be_made
反应并编写逻辑
更新数据框服务器端。
calls_to_be_made_react <- reactiveVal(calls_to_be_made)
observeEvent(input$update_cells, {
## Update dataset
if (min(unlist(input$update_cells)) > 0) {
updated_ctbm <- calls_to_be_made_react()
## Specify what row and column to drop in
updated_ctbm[
input$update_cells[["dest_row"]],
"Caller"] <- callers[
input$update_cells[["source_row"]],
input$update_cells[["source_col"]]]
calls_to_be_made_react(updated_ctbm)
## Make sure the newly drawn table becomes droppable again
droppable()
}
})
if 语句中的条件检查是否正在拖放行名,并且在拖放时不更新数据框 案件。这种情况可以扩展到某种验证 限制哪些单元格可以被哪个可拖动单元格放置的功能,但这超出了这个问题的范围。
在 observableEvent
里面也是我们称之为 droppable
的地方
再次发挥作用。因为 shiny 重绘了整个 table,所以代码
使得 table 可丢弃也需要再次 运行。
最后我们需要更新输出调用,所以它使用反应式
calls_to_be_made
.
output$calls_to_be_made <- renderTable(calls_to_be_made_react(), rownames = T)
这提供了以下服务器功能,可以满足您的要求。
server <- function(input, output, session) {
callers <- tibble(
Caller = c("Jerry", "Donald")
)
calls_to_be_made <- tibble(
Name = c("John", "Fred", "Bill", "Freddy"),
PhoneNumber = c("0123 456 785", "0123 456 6453", "9876 532 432","235 63 430"),
Caller = c("Jerry",NA,NA,NA )
)
jqui_draggable(
ui = "#callers td",
options = list(
revert = "invalid",
helper = "clone"))
droppable <- function() {
jqui_droppable(
ui = "#calls_to_be_made td",
options = list(
drop = JS("function(event, ui) {
Shiny.setInputValue(\"update_cells\", {
source_col: ui.draggable.index(),
source_row: ui.draggable.parent().index() + 1,
dest_col: $(this).index()
dest_row: $(this).parent().index() + 1
});
}")))
}
droppable() #Initialisation
calls_to_be_made_react <- reactiveVal(calls_to_be_made)
observeEvent(input$update_cells, {
## Update dataset
if (min(unlist(input$update_cells)) > 0) {
updated_ctbm <- calls_to_be_made_react()
## Specify what row and column to drop in
updated_ctbm[
input$update_cells[["dest_row"]],
"Caller"] <- callers[
input$update_cells[["source_row"]],
input$update_cells[["source_col"]]]
calls_to_be_made_react(updated_ctbm)
## Make sure the newly drawn table becomes droppable again
droppable()
}
})
output$callers <- renderTable(callers, rownames = T)
output$calls_to_be_made <- renderTable(calls_to_be_made_react(), rownames = T)
}