制作“可疼痛”反应式贴图

时间:2019-09-13 02:16:00

标签: r shiny leaflet reactive shiny-reactivity

我是新来的,所以希望我做得很好,提出了一个很好的问题!

可再现的代码将产生的是北卡罗莱纳州的地图,该地图平均分为四个地理“均匀”区域。想象一下,这是由销售经理分配给其销售人员的区域。

现在做什么:现在,此地图执行以下操作:允许您选择一个区域,然后创建两个表。第一个只是与该县相关联的附加功能的直接数据转储。然后,第二张表将这些数据分组在一起,以产生每个区域的数据总和。

我要执行的操作:假设使用此功能的人要分配新的区域。这些区域中的每一个都分配有一种颜色。 A是红色,B是蓝色,C是绿色,D是黄色。因此,他们为“ A”选择一个输入按钮,然后他开始单击变为红色的县,所有县都进行底部的所有表汇总。完成后,选择“ B”,依此类推。因此,底部的表格如下所示:

+-----------+--------------------+--------------------+
| Territory |       Leads        |       Sales        |
+-----------+--------------------+--------------------+
| A         | selected agg value | selected agg value |
| B         | selected agg value | selected agg value |
| C         | selected agg value | selected agg value |
| D         | selected agg value | selected agg value |
+-----------+--------------------+--------------------+

这有意义吗?

library(tigris)
library(mapview)
library(mapedit)
library(leaflet)
library(dplyr)
library(DT)

north_carolina <- counties("north carolina") %>% st_as_sf() %>% arrange(INTPTLON, INTPTLAT) %>% dplyr::select(NAMELSAD, geometry) %>% rename(county_name = NAMELSAD) %>% 
  mutate(territory = rep(letters[1:4], each = 25), leads = sample(100:1000, 100, replace = TRUE), sales = sample(100:1000, 100, replace = TRUE))

ui <- fluidPage(
  h3("Map"),
  selectModUI(id = "map_select"),
  # Datatable Output
  h3("Table"),
  dataTableOutput(outputId = "BaseTable"),
  h3("Reactive Output"),
  dataTableOutput(outputId = "ReactTable")
)

server <- function(input, output) {

leafmap <- reactive({leaflet() %>%
  addProviderTiles(providers$Stamen.Toner) %>%
  addPolygons(data = north_carolina, fillOpacity = "red",
              fillColor = "grey",
              weight = 5,
              opacity = 5,
              color = "black") %>%
    leafem::addFeatures(data=north_carolina,label = ~htmltools::htmlEscape(territory),
                        layerId = ~seq_len(length(st_geometry(north_carolina))))

})

selectMod <- function(input, output, session, leafmap,
                      styleFalse = list(fillOpacity = 0.2, weight = 1, opacity = 0.4),
                      styleTrue = list(fillOpacity = 0.7, weight = 3, opacity = 0.7))

{
  print("*** custom selectMod")
  output$map <- leaflet::renderLeaflet({
    mapedit:::add_select_script(leafmap, styleFalse = styleFalse, styleTrue = styleTrue,
                                ns = session$ns(NULL))
  })
  id <- "mapedit"
  select_evt <- paste0(id, "_selected")
  df <- data.frame()
  selections <- reactive({
    id <- as.character(input[[select_evt]]$id)
    if (length(df) == 0) {
      # Initial case, first time module is called.
      # Switching map, i.e. subsequent calls to the module.
      # Note that input[[select_evt]] will always keep the last selection event,
      # regardless of this module being called again.
      df <<- data.frame(id = character(0), selected = logical(0),
                        stringsAsFactors = FALSE)
    } else {
      loc <- which(df$id == id)
      if (length(loc) > 0) {
        df[loc, "selected"] <<- input[[select_evt]]$selected
      } else {
        df[nrow(df) + 1, ] <<- c(id, input[[select_evt]]$selected)
      }
    }
    return(df)
  })
  return(selections)
}

rval <- reactiveValues(
  sel = reactive({}),
  selectnum = NULL,
  base_table = north_carolina %>%
    st_set_geometry(NULL) %>%
    dplyr::slice(0)
)

# Create selectMod
observeEvent(leafmap(),
             rval$sel <- callModule(selectMod, "map_select", leafmap())
)

# Subset the table based on the selection
observeEvent(rval$sel(), {
  # The select module returns a reactive
  gs <- rval$sel()
  # Filter for the county data
  rval$selectnum <- as.numeric(gs[which(gs$selected == TRUE), "id"])

  rval$base_table <- north_carolina %>%
    st_set_geometry(NULL) %>%
    dplyr::slice(rval$selectnum)

  rval$react_table <- rval$base_table %>% group_by(territory) %>% summarise(leads = sum(leads), sales = sum(sales))

})

# Create a datatable
output$BaseTable <- renderDataTable({
  datatable(rval$base_table, options = list(scrollX = TRUE))

})

output$ReactTable <- renderDataTable({
  datatable(rval$react_table)

})

}

0 个答案:

没有答案