在传单中使用条形图和散点图的问题答案

【问题标题】：Problem with using barplot and scatter plot in leaflet在传单中使用条形图和散点图的问题
【发布时间】：2021-09-26 00:49:53
【问题描述】：

我正在尝试在传单中同时使用散点图和条形图。日期表、传单和散点图工作正常。问题是当在传单中我们选择地图中的一些点时，条形图不起作用，如下图所示。为什么散点图可以正常工作，而条形图却不行？

如何解决这个问题？这是R代码：

#R code
library(leaflet)
library(crosstalk)
library(DT)
library(dplyr)
library(htmltools)
library(summarywidget)
library(plotly)
#devtools::install_github("jcheng5/d3scatter")
library(d3scatter)

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, key=~ID)
lmap <- leaflet(data = sdf) %>% addTiles() %>%
  addCircleMarkers(data = sdf,
           lng = ~Lon,
           lat = ~Lat,
           group = ~Name1 ,color = ~lab_DB
           ,radius =3
           
  ) 
dtable <- datatable(sdf , width = "100%",editable=TRUE)
ggplt<-ggplot(sdf, aes(x=factor(Value2)))+
  geom_bar(stat="count", width=0.7, fill="steelblue")
d3<-d3scatter(sdf , x=~Value1 ,y=~Value2, width="100%", height=300)
bscols( widths=c(6,6,0), list(lmap, d3),list(dtable,ggplotly(ggplt)))

以下代码显示正确计算的“value2”的#0、#1 和#2 计数！（显示在数据表的标题中）但是条形图有问题！

#R code
library(leaflet)
library(crosstalk)
library(DT)
library(dplyr)
library(htmltools)
library(summarywidget)
library(plotly)
#devtools::install_github("jcheng5/d3scatter")
library(d3scatter)

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, key=~ID)
lmap <- leaflet(data = sdf) %>% addTiles() %>%
  addCircleMarkers(data = sdf,
       lng = ~Lon,
       lat = ~Lat,
       group = ~Name1 ,color = ~lab_DB
       ,radius =3
       
  ) 

ggplt<-ggplotly(sdf %>% ggplot( aes(x=factor(Value2)))+
  geom_bar(stat="count", width=0.7, fill="steelblue"))
d3<-d3scatter(sdf , x=~Value1 ,y=~Value2, width="100%", height=300)
dtable <- datatable(sdf , width = "100%",editable=TRUE, 
caption=tags$caption("Value2:  #0: ",summarywidget(sdf ,     selection=~Value2==0)
,"      Value2:  #1: ",summarywidget(sdf , selection=~Value2==1)
,"      Value2:  #1: ",summarywidget(sdf , selection=~Value2==2)

))

bscols( list(lmap, dtable),list(d3,ggplt), htmltools::p(summarywidget(sdf , selection=~Value2==0,column="Value2")
,summarywidget(sdf , selection=~Value2==1,column="Value2")
,summarywidget(sdf , selection=~Value2==2,column="Value2")
, style="display:none;"))

【问题讨论】：

您希望图表显示由传单上选定/单击的圆形标记过滤的数据？你需要有光泽才能拥有这种交互性。
@rbasa，散点图工作正常，但条形图不行！不发亮能解决吗？
散点图工作正常，因为您使用的是jcheng5/d3scatter，它为“更新数据和刷牙”提供支持。该 github repo 的自述文件指出“不要太认真地对待这个库，它只是作为跨小部件通信的试验场”。它还提供了示例。其中之一是“d3scatter 和 ggplot2 之间的链接刷，使用 Shiny”。
@rbasa，我认为有了这个技巧，我们可以在没有闪亮的情况下处理它stackoverflow.com/questions/68103456/…
@Massoud，它使用 Javascript，而不是 R。如果这是一种您熟悉的语言/环境，那么使用 Javascript 直接与 Plotly Javascript 库交互就可以了。

标签： leaflet dt r-leaflet crosstalk

【解决方案1】：

这是一个有光泽的解决方案。我再次对您的数据表使用回调函数来子集共享数据sdf，以便您可以单击您感兴趣的列并显示条形图：

library(shiny)
library(leaflet)
library(crosstalk)
library(DT)
library(dplyr)
library(htmltools)
library(summarywidget)
library(plotly)
library(d3scatter)

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, leafletOutput("lmap")),
    column(6, d3scatterOutput("scatter"))
  ),
  fluidRow(
    column(6, DTOutput("table")),
    column(6,
           style = "padding-top: 105px;",
           plotlyOutput("plot"))
  )
)

server <- function(input, output) {
  
  sdf <- SharedData$new(data_2, key=~ID)
  
  output$lmap <- renderLeaflet({
    
    leaflet(data = sdf) %>%
    addTiles() %>%
    addCircleMarkers(data = sdf,
                     lng = ~Lon,
                     lat = ~Lat,
                     group = ~Name1 ,color = ~lab_DB,
                     radius =3)
  })
  
  
  output$scatter <- renderD3scatter({
    
    d3scatter(sdf,
              x = ~Value1 ,
              y = ~Value2,
              width = "100%",
              height=300)
    })
  
  output$table <- renderDT({

    datatable(

      sdf,
      filter = 'top',
      editable=TRUE,
      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 <- sdf$data(withSelection = TRUE) %>% 
      filter(selected_ == TRUE) %>%
      pull(input$col) %>% 
      table()

    fig <- plot_ly(
      x = names(dat),
      y = dat,
      name = "Count",
      type = "bar"
    )

    fig

  })
  
}

shinyApp(ui, server)

如果您只对Value2 列感兴趣，那么以下方法也适用：

library(shiny)
library(leaflet)
library(crosstalk)
library(DT)
library(dplyr)
library(htmltools)
library(summarywidget)
library(plotly)
library(d3scatter)

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, leafletOutput("lmap")),
    column(6, d3scatterOutput("scatter"))
  ),
  fluidRow(
    column(6, DTOutput("table")),
    column(6,
           style = "padding-top: 105px;",
           plotlyOutput("plot"))
  )
)

server <- function(input, output) {
  
  sdf <- SharedData$new(data_2, key=~ID)
  
  output$lmap <- renderLeaflet({
    
    leaflet(data = sdf) %>%
    addTiles() %>%
    addCircleMarkers(data = sdf,
                     lng = ~Lon,
                     lat = ~Lat,
                     group = ~Name1 ,color = ~lab_DB,
                     radius =3)
  })
  
  
  output$scatter <- renderD3scatter({
    
    d3scatter(sdf,
              x = ~Value1 ,
              y = ~Value2,
              width = "100%",
              height=300)
    })
  
  output$table <- renderDT({

    datatable(

      sdf,
      filter = 'top',
      editable=TRUE,
      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))
    )
  },
  server = FALSE)

  # plotly bar chart
  output$plot <- renderPlotly({
    
    dat <- sdf$data(withSelection = TRUE) %>% filter(selected_ == TRUE)
    
    p <- ggplot(data = dat,
                aes(x=factor(Value2))) +
      geom_bar(stat="count", width=0.7, fill="steelblue")
    
    ggplotly(p)
    
  })
}

shinyApp(ui, server)

【讨论】：