What the reproducible code will produce is a map of North Carolina, broken out evenly to four geographically "even" regions. Imagine this is being used by a Sales Manager who is assigning territory to his salespeople.
What this does now: Right now, this map does the following: Allows you to select a region, which then creates two tables. The first is just a straight data dump of the accompanying features associated with that county. The second table then groups that data together to produce sums of the data for each region.
What I want this to do: Let's say the person using this wants to assign new territory. Each of those territories are assigned a color. A is red, B is blue, C is green, and D is yellow. So they select an input button for "A" and then he begins to click on counties, which turn red, and all do all the table aggregations at the bottom. Once they're done with that, they select "B", and so on. So then the table at the bottom looks like:
| 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 |
Does that make sense?
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)
})
}
shinyApp(ui,server)