可以巧妙地使用数据表作为源数据吗？
Can plotly use a datatable as source data?
如果我有一个包含值的数据表 (DT)，我可以根据数据表中的这些值在蓝色区域绘制一个 plotly（条形图）吗？例如，对于变量“Value2”，我们有一个条形图。
我看到了，我希望可以通过在上面的R代码中添加一些JavaScript代码来完成。
# R code
library(dplyr)
library(plotly)
library(DT)
library(crosstalk)
library(summarywidget)
library(htmltools)
data_2<-structure(list(ID = 1:8, Name1 = c("A", "A", "A", "C", "B", "B",
"A", "B"), Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12, 43, 54, 34, 23, 77, 44, 22), Value2 = c(0,
1, 1, 0, 0, 0, 0, 2), Lat = c(51.1, 51.6, 57.3, 52.4, 56.3,
54.3, 60.4, 49.2), Lon = c(5, -3, -2, -1, 4, 3, -5, 0), lab_DB = c("blue",
"blue", "blue", "green", "red", "red", "blue", "red")), class = "data.frame", row.names = c(NA,-8L))
sdf <- SharedData$new(data_2, ~ID)
DT1<-datatable(
sdf, filter = 'top',
extensions = c('Select', 'Buttons'), selection = 'none', options = list(select = list(style = 'os', items = 'row'),dom = 'Bfrtip',autoWidth = TRUE,buttons = list('copy' ,
list(extend = 'collection', buttons = c('csv', 'excel', 'pdf', 'print'),
text = 'Download')
)),caption=tags$caption("Value2: #0: ",summarywidget(sdf , selection=~Value2==0)
," Value2: #1: ",summarywidget(sdf , selection=~Value2==1)
," Value2: #2: ",summarywidget(sdf , selection=~Value2==2)
))
bscols(widths = c(6, 4), DT1, div(style = css(width="100%", height="400px", background_color="blue")))
预期的条形图应该像
也就是说，变量“Value2”的简单条形图。
这是一个闪亮的解决方案。我没有使用 {crosstalk}，而是向数据表添加了一个回调以获取所选列的编号。我们可以使用此数字对您的数据进行子集化，并创建显示一列中所有唯一值计数的条形图。
library(shiny)
library(dplyr)
library(plotly)
library(DT)
library(crosstalk)
library(summarywidget)
library(htmltools)
data_2 <- structure(
list(ID = 1:8,
Name1 = c("A", "A", "A", "C", "B", "B", "A", "B"),
Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12, 43, 54, 34, 23, 77, 44, 22),
Value2 = c(0, 1, 1, 0, 0, 0, 0, 2),
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2),
Lon = c(5, -3, -2, -1, 4, 3, -5, 0),
lab_DB = c("blue", "blue", "blue", "green", "red", "red", "blue", "red")),
class = "data.frame",
row.names = c(NA,-8L))
ui <- fluidPage(
fluidRow(
column(6,
DTOutput("table")),
column(6, style = "padding-top: 105px;",
plotlyOutput("plot"))
)
)
server <- function(input, output) {
sdf <- SharedData$new(data_2, ~ID)
output$table <- renderDT({
datatable(
data_2,
filter = 'top',
extensions = c('Select', 'Buttons'),
selection = 'none',
options = list(select = list(style = 'os',
items = 'row'),
dom = 'Bfrtip',
autoWidth = TRUE,
buttons = list('copy' ,
list(extend = 'collection',
buttons = c('csv', 'excel', 'pdf', 'print'),
text = 'Download'))),
caption = tags$caption("Value2: #0: ",
summarywidget(sdf, selection = ~Value2 == 0),
" Value2: #1: ", summarywidget(sdf, selection = ~Value2 == 1),
" Value2: #2: ", summarywidget(sdf, selection = ~Value2 == 2)),
# This part is new: callback to get col number as `input$col`
callback = JS("table.on('click.dt', 'td', function() {
var col=table.cell(this).index().column;
var data = [col];
Shiny.onInputChange('col',data );
});")
)
},
server = FALSE)
# plotly bar chart
output$plot <- renderPlotly({
req(input$col)
dat <- table(data_2[, input$col])
fig <- plot_ly(
x = names(dat),
y = dat,
name = "Count",
type = "bar"
)
fig
})
}
shinyApp(ui, server)
这是我的会话信息，因为上面的代码似乎无法在 OP 的机器上运行：
R version 4.0.2 (2020-06-22)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 18363)
Matrix products: default
locale:
[1] LC_COLLATE=German_Germany.1252 LC_CTYPE=German_Germany.1252
[3] LC_MONETARY=German_Germany.1252 LC_NUMERIC=C
[5] LC_TIME=German_Germany.1252
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] shiny_1.5.0 htmltools_0.5.0 summarywidget_0.0.0.9000
[4] crosstalk_1.1.0.1 DT_0.15 plotly_4.9.2.1
[7] forcats_0.5.0 stringr_1.4.0 purrr_0.3.4
[10] readr_1.3.1 tibble_3.1.1 ggplot2_3.3.3
[13] tidyverse_1.3.0 tidyr_1.1.1 dplyr_1.0.1
loaded via a namespace (and not attached):
[1] httr_1.4.2 jsonlite_1.7.0 viridisLite_0.3.0 modelr_0.1.8 assertthat_0.2.1
[6] blob_1.2.1 cellranger_1.1.0 yaml_2.2.1 pillar_1.6.1 backports_1.1.7
[11] glue_1.4.1 digest_0.6.25 promises_1.1.1 rvest_0.3.6 colorspace_1.4-1
[16] httpuv_1.5.4 clipr_0.7.0 pkgconfig_2.0.3 broom_0.7.0 haven_2.3.1
[21] xtable_1.8-4 scales_1.1.1 processx_3.4.3 whisker_0.4 later_1.1.0.1
[26] generics_0.0.2 ellipsis_0.3.2 withr_2.2.0 lazyeval_0.2.2 cli_2.0.2
[31] magrittr_1.5 crayon_1.3.4 readxl_1.3.1 mime_0.9 evaluate_0.14
[36] ps_1.3.3 fs_1.5.0 fansi_0.4.1 xml2_1.3.2 rsconnect_0.8.16
[41] tools_4.0.2 data.table_1.13.0 hms_0.5.3 lifecycle_1.0.0 munsell_0.5.0
[46] reprex_0.3.0 callr_3.4.3 compiler_4.0.2 tinytex_0.31 rlang_0.4.10
[51] grid_4.0.2 rstudioapi_0.11 htmlwidgets_1.5.1 rmarkdown_2.8 gtable_0.3.0
[56] DBI_1.1.0 R6_2.4.1 lubridate_1.7.9 knitr_1.29 fastmap_1.0.1
[61] utf8_1.1.4 stringi_1.4.6 Rcpp_1.0.5 vctrs_0.3.8 dbplyr_1.4.4
[66] tidyselect_1.1.0 xfun_0.22
>
如果我有一个包含值的数据表 (DT)，我可以根据数据表中的这些值在蓝色区域绘制一个 plotly（条形图）吗？例如，对于变量“Value2”，我们有一个条形图。
我看到了
# R code
library(dplyr)
library(plotly)
library(DT)
library(crosstalk)
library(summarywidget)
library(htmltools)
data_2<-structure(list(ID = 1:8, Name1 = c("A", "A", "A", "C", "B", "B",
"A", "B"), Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12, 43, 54, 34, 23, 77, 44, 22), Value2 = c(0,
1, 1, 0, 0, 0, 0, 2), Lat = c(51.1, 51.6, 57.3, 52.4, 56.3,
54.3, 60.4, 49.2), Lon = c(5, -3, -2, -1, 4, 3, -5, 0), lab_DB = c("blue",
"blue", "blue", "green", "red", "red", "blue", "red")), class = "data.frame", row.names = c(NA,-8L))
sdf <- SharedData$new(data_2, ~ID)
DT1<-datatable(
sdf, filter = 'top',
extensions = c('Select', 'Buttons'), selection = 'none', options = list(select = list(style = 'os', items = 'row'),dom = 'Bfrtip',autoWidth = TRUE,buttons = list('copy' ,
list(extend = 'collection', buttons = c('csv', 'excel', 'pdf', 'print'),
text = 'Download')
)),caption=tags$caption("Value2: #0: ",summarywidget(sdf , selection=~Value2==0)
," Value2: #1: ",summarywidget(sdf , selection=~Value2==1)
," Value2: #2: ",summarywidget(sdf , selection=~Value2==2)
))
bscols(widths = c(6, 4), DT1, div(style = css(width="100%", height="400px", background_color="blue")))
预期的条形图应该像
也就是说，变量“Value2”的简单条形图。
这是一个闪亮的解决方案。我没有使用 {crosstalk}，而是向数据表添加了一个回调以获取所选列的编号。我们可以使用此数字对您的数据进行子集化，并创建显示一列中所有唯一值计数的条形图。
library(shiny)
library(dplyr)
library(plotly)
library(DT)
library(crosstalk)
library(summarywidget)
library(htmltools)
data_2 <- structure(
list(ID = 1:8,
Name1 = c("A", "A", "A", "C", "B", "B", "A", "B"),
Name2 = c("a", "b", "b", "a", "b", "a", "b", "c"),
Value1 = c(12, 43, 54, 34, 23, 77, 44, 22),
Value2 = c(0, 1, 1, 0, 0, 0, 0, 2),
Lat = c(51.1, 51.6, 57.3, 52.4, 56.3, 54.3, 60.4, 49.2),
Lon = c(5, -3, -2, -1, 4, 3, -5, 0),
lab_DB = c("blue", "blue", "blue", "green", "red", "red", "blue", "red")),
class = "data.frame",
row.names = c(NA,-8L))
ui <- fluidPage(
fluidRow(
column(6,
DTOutput("table")),
column(6, style = "padding-top: 105px;",
plotlyOutput("plot"))
)
)
server <- function(input, output) {
sdf <- SharedData$new(data_2, ~ID)
output$table <- renderDT({
datatable(
data_2,
filter = 'top',
extensions = c('Select', 'Buttons'),
selection = 'none',
options = list(select = list(style = 'os',
items = 'row'),
dom = 'Bfrtip',
autoWidth = TRUE,
buttons = list('copy' ,
list(extend = 'collection',
buttons = c('csv', 'excel', 'pdf', 'print'),
text = 'Download'))),
caption = tags$caption("Value2: #0: ",
summarywidget(sdf, selection = ~Value2 == 0),
" Value2: #1: ", summarywidget(sdf, selection = ~Value2 == 1),
" Value2: #2: ", summarywidget(sdf, selection = ~Value2 == 2)),
# This part is new: callback to get col number as `input$col`
callback = JS("table.on('click.dt', 'td', function() {
var col=table.cell(this).index().column;
var data = [col];
Shiny.onInputChange('col',data );
});")
)
},
server = FALSE)
# plotly bar chart
output$plot <- renderPlotly({
req(input$col)
dat <- table(data_2[, input$col])
fig <- plot_ly(
x = names(dat),
y = dat,
name = "Count",
type = "bar"
)
fig
})
}
shinyApp(ui, server)
这是我的会话信息，因为上面的代码似乎无法在 OP 的机器上运行：
R version 4.0.2 (2020-06-22)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 18363)
Matrix products: default
locale:
[1] LC_COLLATE=German_Germany.1252 LC_CTYPE=German_Germany.1252
[3] LC_MONETARY=German_Germany.1252 LC_NUMERIC=C
[5] LC_TIME=German_Germany.1252
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] shiny_1.5.0 htmltools_0.5.0 summarywidget_0.0.0.9000
[4] crosstalk_1.1.0.1 DT_0.15 plotly_4.9.2.1
[7] forcats_0.5.0 stringr_1.4.0 purrr_0.3.4
[10] readr_1.3.1 tibble_3.1.1 ggplot2_3.3.3
[13] tidyverse_1.3.0 tidyr_1.1.1 dplyr_1.0.1
loaded via a namespace (and not attached):
[1] httr_1.4.2 jsonlite_1.7.0 viridisLite_0.3.0 modelr_0.1.8 assertthat_0.2.1
[6] blob_1.2.1 cellranger_1.1.0 yaml_2.2.1 pillar_1.6.1 backports_1.1.7
[11] glue_1.4.1 digest_0.6.25 promises_1.1.1 rvest_0.3.6 colorspace_1.4-1
[16] httpuv_1.5.4 clipr_0.7.0 pkgconfig_2.0.3 broom_0.7.0 haven_2.3.1
[21] xtable_1.8-4 scales_1.1.1 processx_3.4.3 whisker_0.4 later_1.1.0.1
[26] generics_0.0.2 ellipsis_0.3.2 withr_2.2.0 lazyeval_0.2.2 cli_2.0.2
[31] magrittr_1.5 crayon_1.3.4 readxl_1.3.1 mime_0.9 evaluate_0.14
[36] ps_1.3.3 fs_1.5.0 fansi_0.4.1 xml2_1.3.2 rsconnect_0.8.16
[41] tools_4.0.2 data.table_1.13.0 hms_0.5.3 lifecycle_1.0.0 munsell_0.5.0
[46] reprex_0.3.0 callr_3.4.3 compiler_4.0.2 tinytex_0.31 rlang_0.4.10
[51] grid_4.0.2 rstudioapi_0.11 htmlwidgets_1.5.1 rmarkdown_2.8 gtable_0.3.0
[56] DBI_1.1.0 R6_2.4.1 lubridate_1.7.9 knitr_1.29 fastmap_1.0.1
[61] utf8_1.1.4 stringi_1.4.6 Rcpp_1.0.5 vctrs_0.3.8 dbplyr_1.4.4
[66] tidyselect_1.1.0 xfun_0.22
>