可以将数据表用作源数据吗？

Question

如果我有一个包含值的数据表 (DT)，我可以根据数据表中的这些值在蓝色区域绘制一个 plotly（条形图）吗？例如对于变量“Value2”，我们有一个条形图。

我看到this post，我希望可以通过在上面的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”的简单条形图。

Answer 1

这是一个有光泽的解决方案。我没有使用{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        
>