如何将完整的数据框对象复制到剪贴板？
How do I copy a complete data frame object to clipboard?
查看底部的解决方案选项！
我正在尝试创建一个 actionButton()（在下面的代码中 ID 是 transCopy）到 copy/paste 从 Shiny 渲染到 tables 到 Excel .在下面的代码中，它适用于转换table（对象results()）的不完整提取，但不适用于显示转换的每个output$resultsDT的完整对象（如results()) PLUS from/to 沿 Shiny 渲染的 table 的顶行过渡的句点。
我尝试从 output$resultsDT 中拉出 datatable(...) 并用它创建一个新的反应对象，将其同时送入 output$resultsDT 和剪贴板复制函数 write.table(x = ...) 中下面是单个 observeEvent()，但出现“<- 中的错误：类型 'closure' 的对象不是子集 table”。我尝试了其他方法，但还没有成功。
那么我该如何更改它以便用户可以 copy/paste 更完整的 table 版本到 Excel？格式不需要完全相同（尽管如果是的话会很好），即使是粘贴 table 顶部的 2 行指定“From = x”和“To = y”也是有帮助，因此用户以后可以看到用于导出 table post 的输入-粘贴到 Excel.
底部的图片更好地解释。
最后，如果可能的话，我喜欢坚持使用基数 R（例如 write.table()），否则，在更完整的代码中，我会受到 package-bloat 的影响。
可重现代码：
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1,1,1,2,2,2,3,3,3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X9")
)
numTransit <- function(x, from=1, to=3){
setDT(x)
unique_state <- unique(x$State)
all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[,.N, c("from_state", "to_state")]
[all_states,on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N"
)
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From period:", 1, min = 1, max = 3),
numericInput("transTo", "To period:", 2, min = 1, max = 3),
actionButton(inputId = "transCopy", "Copy", width = "20%"),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(rowspan = 2,
sprintf('To state where end period = %s', input$transTo),
style = "border-right: solid 1px;"),
tags$th(colspan = 10,
sprintf('From state where initial period = %s', input$transFrom)
)
),
tags$tr(
mapply(tags$th, colnames(results())[-1], style = sprintf("border-right: solid %spx;", rep(0, ncol(results()) - 1L)), SIMPLIFY = FALSE)
)
)
),
options = list(scrollX = F
, dom = 'ft'
, lengthChange = T
, pagingType = "numbers"
, autoWidth = T
, info = FALSE
, searching = FALSE
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
observeEvent(input$transCopy,
write.table(x = results(),
file = "clipboard",
sep = "\t",
row.names = FALSE,
col.names = TRUE
))
}
shinyApp(ui, server)
UI 首次调用应用时：
现在从剪贴板粘贴到 Excel:
上述OP的更简单解决方案：
根据 中 r2Evans 的建议，将 OP 代码中的 observeEvent() 替换为以下内容：
observeEvent(
req(input$transFrom, input$transTo),
writeLines(
c(sprintf('Column headers show transition `from-state` where initial period = %s', input$transFrom),
sprintf('Row headers show transition `to-state` where end period = %s', input$transTo),
capture.output(
write.table(x = results(),
sep = "\t",
row.names = FALSE,
col.names = TRUE)
)
),
"clipboard"
)
)
此替代方案 observeEvent() 在转换 table 上方输出两行描述，因此用户在 copying/pasting 和 table 时看到转换输入。在 Excel 中格式化是如此简单，以至于从 R 中粘贴一个完美格式化的 table 是没有意义的（而且那将是多么复杂）。以下是粘贴到 Excel:
时的示例输出
虽然我自己没试过，但是clipr好像可以如你所愿
library(shiny)
library(clipr)
library(rhandsontable)
ui <- fluidPage(
actionButton(inputId = 'click',label = 'COPY'),
p('Click COPY and paste the results below witch Ctrl+V.'),
rHandsontableOutput('rhot')
)
server <- function(input, output, session) {
output$rhot = renderRHandsontable({
df = data.frame(lapply(1:10, function(x){rep('',10)}))
colnames(df) = paste('c',1:10)
rhandsontable(df)
})
observeEvent(input$click,{
clipr::write_clip(mtcars)
})
}
shinyApp(ui, server)
您可以使用 JavaScript 复制带有添加标题的整个 table，如果您需要的话。
在下面的示例中，我根据找到的答案 here 添加了一个 HTML() 块。
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1, 1, 1, 2, 2, 2, 3, 3, 3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0", "X1", "X2", "X0", "X2", "X0", "X2", "X1", "X9")
)
numTransit <- function(x, from = 1, to = 3) {
setDT(x)
unique_state <- unique(x$State)
all_states <-
setDT(expand.grid(list(
from_state = unique_state, to_state = unique_state
)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[, .N, c("from_state", "to_state")]
[all_states, on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N")
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From period:", 1, min = 1, max = 3),
numericInput("transTo", "To period:", 2, min = 1, max = 3),
actionButton(inputId = "transCopy", "Copy", width = "20%"),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
HTML(
'
<script type="text/javascript">
function copytable(el) {
var urlField = document.getElementById(el)
var range = document.createRange()
range.selectNode(urlField)
window.getSelection().addRange(range)
document.execCommand(\'copy\')
}
</script>
<input type=button value="Copy to Clipboard" onClick="copytable(\'DataTables_Table_0\')">
')
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~ (if (is.numeric(.))
sum(.)
else
"Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- DT::renderDT(server = FALSE, {
DT::datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(class = 'display',
tags$thead(
tags$tr(
tags$th(
rowspan = 2,
sprintf('To state where end period = %s', input$transTo),
style = "border-right: solid 1px;"
),
tags$th(
colspan = 10,
sprintf('From state where initial period = %s', input$transFrom)
)
),
tags$tr(
mapply(
tags$th,
colnames(results())[-1],
style = sprintf("border-right: solid %spx;", rep(0, ncol(results(
)) - 1L)),
SIMPLIFY = FALSE
)
)
)),
options = list(
scrollX = F,
dom = 'ft',
lengthChange = T,
pagingType = "numbers",
autoWidth = T,
info = FALSE,
searching = FALSE,
extensions = c("Buttons"),
buttons = list('copy')
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
observeEvent(input$transCopy, {
print(results())
clipr::write_clip(content = results())
})
}
shinyApp(ui, server)
查看底部的解决方案选项！
我正在尝试创建一个 actionButton()（在下面的代码中 ID 是 transCopy）到 copy/paste 从 Shiny 渲染到 tables 到 Excel .在下面的代码中，它适用于转换table（对象results()）的不完整提取，但不适用于显示转换的每个output$resultsDT的完整对象（如results()) PLUS from/to 沿 Shiny 渲染的 table 的顶行过渡的句点。
我尝试从 output$resultsDT 中拉出 datatable(...) 并用它创建一个新的反应对象，将其同时送入 output$resultsDT 和剪贴板复制函数 write.table(x = ...) 中下面是单个 observeEvent()，但出现“<- 中的错误：类型 'closure' 的对象不是子集 table”。我尝试了其他方法，但还没有成功。
那么我该如何更改它以便用户可以 copy/paste 更完整的 table 版本到 Excel？格式不需要完全相同（尽管如果是的话会很好），即使是粘贴 table 顶部的 2 行指定“From = x”和“To = y”也是有帮助，因此用户以后可以看到用于导出 table post 的输入-粘贴到 Excel.
底部的图片更好地解释。
最后，如果可能的话，我喜欢坚持使用基数 R（例如 write.table()），否则，在更完整的代码中，我会受到 package-bloat 的影响。
可重现代码：
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1,1,1,2,2,2,3,3,3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0","X1","X2","X0","X2","X0", "X2","X1","X9")
)
numTransit <- function(x, from=1, to=3){
setDT(x)
unique_state <- unique(x$State)
all_states <- setDT(expand.grid(list(from_state = unique_state, to_state = unique_state)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[,.N, c("from_state", "to_state")]
[all_states,on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N"
)
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From period:", 1, min = 1, max = 3),
numericInput("transTo", "To period:", 2, min = 1, max = 3),
actionButton(inputId = "transCopy", "Copy", width = "20%"),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~(if(is.numeric(.)) sum(.) else "Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- renderDT(server=FALSE, {
datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(
class = 'display',
tags$thead(
tags$tr(
tags$th(rowspan = 2,
sprintf('To state where end period = %s', input$transTo),
style = "border-right: solid 1px;"),
tags$th(colspan = 10,
sprintf('From state where initial period = %s', input$transFrom)
)
),
tags$tr(
mapply(tags$th, colnames(results())[-1], style = sprintf("border-right: solid %spx;", rep(0, ncol(results()) - 1L)), SIMPLIFY = FALSE)
)
)
),
options = list(scrollX = F
, dom = 'ft'
, lengthChange = T
, pagingType = "numbers"
, autoWidth = T
, info = FALSE
, searching = FALSE
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
observeEvent(input$transCopy,
write.table(x = results(),
file = "clipboard",
sep = "\t",
row.names = FALSE,
col.names = TRUE
))
}
shinyApp(ui, server)
UI 首次调用应用时：
现在从剪贴板粘贴到 Excel:
上述OP的更简单解决方案：
根据 observeEvent() 替换为以下内容：
observeEvent(
req(input$transFrom, input$transTo),
writeLines(
c(sprintf('Column headers show transition `from-state` where initial period = %s', input$transFrom),
sprintf('Row headers show transition `to-state` where end period = %s', input$transTo),
capture.output(
write.table(x = results(),
sep = "\t",
row.names = FALSE,
col.names = TRUE)
)
),
"clipboard"
)
)
此替代方案 observeEvent() 在转换 table 上方输出两行描述，因此用户在 copying/pasting 和 table 时看到转换输入。在 Excel 中格式化是如此简单，以至于从 R 中粘贴一个完美格式化的 table 是没有意义的（而且那将是多么复杂）。以下是粘贴到 Excel:
虽然我自己没试过，但是clipr好像可以如你所愿
library(shiny)
library(clipr)
library(rhandsontable)
ui <- fluidPage(
actionButton(inputId = 'click',label = 'COPY'),
p('Click COPY and paste the results below witch Ctrl+V.'),
rHandsontableOutput('rhot')
)
server <- function(input, output, session) {
output$rhot = renderRHandsontable({
df = data.frame(lapply(1:10, function(x){rep('',10)}))
colnames(df) = paste('c',1:10)
rhandsontable(df)
})
observeEvent(input$click,{
clipr::write_clip(mtcars)
})
}
shinyApp(ui, server)
您可以使用 JavaScript 复制带有添加标题的整个 table，如果您需要的话。
在下面的示例中，我根据找到的答案 here 添加了一个 HTML() 块。
library(DT)
library(shiny)
library(dplyr)
library(htmltools)
library(data.table)
data <-
data.frame(
ID = c(1, 1, 1, 2, 2, 2, 3, 3, 3),
Period = c(1, 2, 3, 1, 2, 3, 1, 2, 3),
Values = c(5, 10, 15, 0, 2, 4, 3, 6, 9),
State = c("X0", "X1", "X2", "X0", "X2", "X0", "X2", "X1", "X9")
)
numTransit <- function(x, from = 1, to = 3) {
setDT(x)
unique_state <- unique(x$State)
all_states <-
setDT(expand.grid(list(
from_state = unique_state, to_state = unique_state
)))
dcast(x[, .(from_state = State[from],
to_state = State[to]),
by = ID]
[, .N, c("from_state", "to_state")]
[all_states, on = c("from_state", "to_state")],
to_state ~ from_state, value.var = "N")
}
ui <- fluidPage(
tags$head(tags$style(".datatables .display {margin-left: 0;}")),
h4(strong("Transition table inputs:")),
numericInput("transFrom", "From period:", 1, min = 1, max = 3),
numericInput("transTo", "To period:", 2, min = 1, max = 3),
actionButton(inputId = "transCopy", "Copy", width = "20%"),
h4(strong("Output transition table:")),
DTOutput("resultsDT"),
HTML(
'
<script type="text/javascript">
function copytable(el) {
var urlField = document.getElementById(el)
var range = document.createRange()
range.selectNode(urlField)
window.getSelection().addRange(range)
document.execCommand(\'copy\')
}
</script>
<input type=button value="Copy to Clipboard" onClick="copytable(\'DataTables_Table_0\')">
')
)
server <- function(input, output, session) {
results <-
reactive({
results <- numTransit(data, input$transFrom, input$transTo) %>%
replace(is.na(.), 0) %>%
bind_rows(summarise_all(., ~ (if (is.numeric(.))
sum(.)
else
"Sum")))
results <- cbind(results, Sum = rowSums(results[,-1]))
})
output$data <- renderTable(data)
output$resultsDT <- DT::renderDT(server = FALSE, {
DT::datatable(
data = results(),
rownames = FALSE,
filter = 'none',
container = tags$table(class = 'display',
tags$thead(
tags$tr(
tags$th(
rowspan = 2,
sprintf('To state where end period = %s', input$transTo),
style = "border-right: solid 1px;"
),
tags$th(
colspan = 10,
sprintf('From state where initial period = %s', input$transFrom)
)
),
tags$tr(
mapply(
tags$th,
colnames(results())[-1],
style = sprintf("border-right: solid %spx;", rep(0, ncol(results(
)) - 1L)),
SIMPLIFY = FALSE
)
)
)),
options = list(
scrollX = F,
dom = 'ft',
lengthChange = T,
pagingType = "numbers",
autoWidth = T,
info = FALSE,
searching = FALSE,
extensions = c("Buttons"),
buttons = list('copy')
),
class = "display"
) %>%
formatStyle(c(1), `border-right` = "solid 1px")
})
observeEvent(input$transCopy, {
print(results())
clipr::write_clip(content = results())
})
}
shinyApp(ui, server)