|
|
@@ -0,0 +1,118 @@ |
|
|
|
library(tidyverse) |
|
|
|
library(shiny) |
|
|
|
library(leaflet) |
|
|
|
library(RColorBrewer) |
|
|
|
library(sp) |
|
|
|
library(rgdal) |
|
|
|
library(plotly) |
|
|
|
library(stringr) |
|
|
|
|
|
|
|
read.csv("ghm.csv") %>% |
|
|
|
`names<-`(c("IPP", "IEP", "Age", "Sexe", "CP", "GHM", "date_entree", "date_sortie")) %>% |
|
|
|
mutate(DS = as.numeric(date_sortie - date_entree), |
|
|
|
Sexe = Sexe %>% factor(labels = c("Homme", "Femme"))) -> GHM |
|
|
|
|
|
|
|
read_csv2("insee.csv") %>% |
|
|
|
select(Codepos, insee = INSEE) %>% |
|
|
|
# filter(Codepos %in% GHM$CP), |
|
|
|
filter(Codepos %>% str_detect("^(54|57|55|88)")) %>% |
|
|
|
mutate(insee = insee %>% as.character)-> insee |
|
|
|
|
|
|
|
readOGR("communes/") -> communes |
|
|
|
|
|
|
|
communes@data %>% |
|
|
|
left_join(insee) -> communes@data |
|
|
|
|
|
|
|
communes <- communes[!is.na(communes$Codepos),] |
|
|
|
|
|
|
|
lngs <- communes@polygons %>% map(~slot(.x, "labpt")) %>% map_dbl(1) |
|
|
|
lats <- communes@polygons %>% map(~slot(.x, "labpt")) %>% map_dbl(2) |
|
|
|
|
|
|
|
ui <- bootstrapPage( |
|
|
|
tags$style(type = "text/css", "html, body {width:100%;height:100%}"), |
|
|
|
leafletOutput("map", width = "100%", height = "100%"), |
|
|
|
absolutePanel(top = 10, right = 10, |
|
|
|
# GHM |
|
|
|
# plotlyOutput("plot_ghm"), |
|
|
|
# selectizeInput("choice_ghm", "GHM", GHM$GHM %>% factor %>% levels, multiple = T), |
|
|
|
# Age |
|
|
|
# plotlyOutput("plot_age"), |
|
|
|
# sliderInput("slider_age", "Age", min(GHM$Age), max(GHM$Age), value = c(min(GHM$Age), max(GHM$Age))), |
|
|
|
# Sexe |
|
|
|
# plotlyOutput("plot_sexe"), |
|
|
|
checkboxGroupInput("check_sexe", "Sexe", c("Homme", "Femme"), c("Homme", "Femme")) |
|
|
|
), |
|
|
|
absolutePanel(bottom = 10, left = "5%", width = "90%", |
|
|
|
sliderInput("slider_date", "Dates", width = "100%", min = as.Date("2005-01-01"), max = as.Date("2017-01-01"), value = c(as.Date("2016-01-01"), as.Date("2017-01-01")), animate = animationOptions(interval = 0)) |
|
|
|
) |
|
|
|
) |
|
|
|
|
|
|
|
server <- function(input, output, session) |
|
|
|
{ |
|
|
|
# Create map |
|
|
|
output$map <- renderLeaflet({ |
|
|
|
leaflet(communes, options = leafletOptions(minZoom = 7, maxZoom = 15)) %>% |
|
|
|
addProviderTiles(providers$CartoDB.Positron) %>% |
|
|
|
addPolygons(weight = 1, color = "#222222", opacity = .1, fillOpacity = .1, fillColor = "#EEEEEE") %>% |
|
|
|
setView(lat = 48.35, lng = 6, zoom = 9) |
|
|
|
}) |
|
|
|
# Filter in bounds |
|
|
|
in_bounds <- reactive({ |
|
|
|
if (is.null(input$map_bounds)) |
|
|
|
return(communes[F,]) |
|
|
|
bounds <- input$map_bounds |
|
|
|
latrng <- range(bounds$north, bounds$south) |
|
|
|
lngrng <- range(bounds$east, bounds$west) |
|
|
|
communes[lats >= latrng[1] & lats <= latrng[2] & lngs >= lngrng[1] & lngs <= lngrng[2],] |
|
|
|
}) |
|
|
|
# Filter GHM |
|
|
|
# filteredData <- reactive({ |
|
|
|
# GHM %>% |
|
|
|
# filter(Sexe %in% input$check_sexe, |
|
|
|
# Age <= input$slider_age[2] & Age >= input$slider_age[1], |
|
|
|
# GHM %in% input$choice_ghm, |
|
|
|
# date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1], |
|
|
|
# CP %in% in_bounds$insee) |
|
|
|
# }) |
|
|
|
# Plots |
|
|
|
# observe({ |
|
|
|
# output$plot_sexe <- renderPlotly({ |
|
|
|
# filteredData() %>% |
|
|
|
# ( |
|
|
|
# ggplot() + |
|
|
|
# aes(x = Sexe) + |
|
|
|
# geom_bar(position = "stacked") |
|
|
|
# ) %>% ggplotly |
|
|
|
# }) |
|
|
|
# }) |
|
|
|
# observe({ |
|
|
|
# output$plot_age <- renderPlotly({ |
|
|
|
# filteredData() %>% |
|
|
|
# ( |
|
|
|
# ggplot() + |
|
|
|
# aes(x = Age, y = ..density..) + |
|
|
|
# geom_histogram() + |
|
|
|
# geom_density() |
|
|
|
# ) %>% ggplotly |
|
|
|
# }) |
|
|
|
# }) |
|
|
|
# observe({ |
|
|
|
# leafletProxy("map", data = in_bounds()) %>% |
|
|
|
# clearShapes() %>% |
|
|
|
# }) |
|
|
|
# Use a separate observer to recreate the legend as needed. |
|
|
|
# observe({ |
|
|
|
# Remove any existing legend, and only if the legend is |
|
|
|
# enabled, create a new one. |
|
|
|
# leafletProxy("map", data = quakes) %>% |
|
|
|
# clearControls() |
|
|
|
# if (input$legend) { |
|
|
|
# pal <- colorpal() |
|
|
|
# proxy %>% addLegend(position = "bottomright", |
|
|
|
# pal = pal, values = ~mag |
|
|
|
# ) |
|
|
|
# } |
|
|
|
# }) |
|
|
|
} |
|
|
|
|
|
|
|
shinyApp(ui = ui, server = server) |