javascriptrcrosstalk

Can plotly use a datatable as source data?

If I have a datatable (DT) that contains values, can I have a plotly(a barplot) in blue area based on those values in datatable? For example for variable "Value2", we have a barplot.

enter image description here

I saw this post and I hope it can be done by add some JavaScript code to the above R code.

 # 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")))

The expected bar plot should be like

enter image description here

That is, a simple bar plot for variable "Value2".

Solution

  • Here is a solution with shiny. Instead of using {crosstalk} I added a callback to the datatable to get the number of the selected column. We can use this number to subset your data and create said plotly bar chart which shows the count of all unique values in a column.

    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)

    Here my session info, since the code above seems not to be working on the OP's machine:

    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        
>