|
- library(tidyverse)
- library(shiny)
- library(leaflet)
- library(RColorBrewer)
- library(sp)
- library(rgdal)
- library(plotly)
- library(stringr)
- library(lubridate)
-
- # Lecture fichier de GHM ----
- read_csv("ghm.csv", col_types = cols(IPP = col_character())) %>%
- `names<-`(c("IPP", "IEP", "Age", "Sexe", "CP", "GHM", "date_entree", "date_sortie")) %>%
- mutate(date_entree = date_entree %>% as.Date(format = "%Y/%m/%d"),
- date_sortie = date_sortie %>% as.Date(format = "%Y/%m/%d"),
- DS = as.numeric(date_sortie - date_entree),
- Sexe = Sexe %>% factor(labels = c("Homme", "Femme"))) -> GHM
-
- # Lecture labels racines de GHM et garder celles existantes ----
- read_csv("racinesGHM.csv") %>%
- mutate(codlib = str_c(racine, " - ", libelle)) -> racines
- racine <- racines$racine
- names(racine) <- racines$codlib
-
- racine <- racine[racine %in% GHM$GHM]
- rm(racines)
-
- # Lecture codes postaux <-> codes insee et garder ceux existants ----
- read_csv2("insee.csv", col_types = cols(INSEE = col_character())) %>%
- select(Codepos, insee = INSEE) %>%
- mutate(insee = insee %>% str_pad(5, "left", "0")) %>%
- filter(Codepos %in% GHM$CP) -> insee
-
- # Lecture carte et join avec codes postaux ----
- readOGR("communes", "communes-20150101-100m") -> communes
-
- communes@data %>%
- left_join(insee) -> communes@data
-
- communes <- communes[!is.na(communes$Codepos),]
-
- rm(insee)
-
- # long/lat de chaque commune ----
-
- lngs <- communes@polygons %>% map(~slot(.x, "labpt")) %>% map_dbl(1)
- lats <- communes@polygons %>% map(~slot(.x, "labpt")) %>% map_dbl(2)
- min_age <- GHM$Age %>% min(na.rm = T)
- max_age <- GHM$Age %>% max(na.rm = T)
- min_date <- GHM$date_entree %>% min(na.rm =T)
- max_date <- GHM$date_sortie %>% max(na.rm =T)
-
- # UI ----
- ui <- bootstrapPage(
- tags$style(type = "text/css", "html, body {width:100%;height:100%}"),
- leafletOutput("map", width = "100%", height = "100%"),
- absolutePanel(top = 10, right = 10, width = "20%",
- # GHM
- plotOutput("plot_ghm", height = 200),
- selectizeInput("choice_ghm", "GHM", racine, multiple = T),
- # Age
- plotOutput("plot_age", height = 200),
- sliderInput("slider_age", "Age", min_age, max_age, value = c(min_age, max_age)),
- # Sexe
- plotOutput("plot_sexe", height = 200),
- checkboxGroupInput("check_sexe", "Sexe", c("Homme", "Femme"), c("Homme", "Femme"))
- ),
- absolutePanel(bottom = 10, left = "2.5%", width = "75%",
- sliderInput("slider_date", "Dates", width = "100%", min = min_date, max = max_date, value = c(max_date - years(1), max_date), animate = animationOptions(interval = 0))
- )
- )
-
- # Server ----
- server <- function(input, output, session)
- {
- # Create map
- output$map <- renderLeaflet({
- leaflet(communes, options = leafletOptions(minZoom = 6, maxZoom = 14)) %>%
- addProviderTiles(providers$CartoDB.Positron) %>%
- #addPolygons(weight = 1, color = "#222222", opacity = .1, fillOpacity = .1, fillColor = "#EEEEEE") %>%
- setView(lat = 48.35, lng = 6, zoom = 8)
- })
-
- # 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({
- if (input$choice_ghm %>% is.null)
- {
- GHM %>%
- filter(Sexe %in% input$check_sexe,
- Age <= input$slider_age[2] & Age >= input$slider_age[1],
- date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1],
- CP %in% in_bounds()$Codepos)
- } else
- {
- 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()$Codepos)
- }
- })
-
- # GHM
- data_ghm <- reactive({
- GHM %>%
- filter(Age <= input$slider_age[2] & Age >= input$slider_age[1],
- date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1],
- CP %in% in_bounds()$Codepos,
- Sexe %in% input$check_sexe)
- })
-
- output$plot_ghm <- renderPlot({
- data_ghm() %>%
- count(GHM) %>%
- top_n(10) %>%
- arrange(n) %>%
- mutate(GHM = GHM %>% factor(levels = GHM)) %>%
- ggplot() +
- aes(x = GHM, y = n) +
- geom_bar(stat = "identity") +
- coord_flip() +
- theme(axis.title = element_blank())
- })
-
- # Sexe
- data_sexe <- reactive({
- if (input$choice_ghm %>% is.null)
- {
- GHM %>%
- filter(Age <= input$slider_age[2] & Age >= input$slider_age[1],
- date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1],
- CP %in% in_bounds()$Codepos)
- } else
- {
- GHM %>%
- filter(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()$Codepos)
- }
- })
-
- output$plot_sexe <- renderPlot({
- data_sexe() %>%
- ggplot() +
- aes(x = 1, fill = Sexe) +
- geom_bar() +
- coord_flip() +
- scale_fill_manual(values = c("Homme" = "lightblue", "Femme" = "pink")) +
- theme(axis.title = element_blank(),
- legend.position = "none",
- axis.text.y = element_blank(),
- axis.ticks.y = element_blank())
- })
-
- # Age
- data_age <- reactive({
- if (input$choice_ghm %>% is.null)
- {
- GHM %>%
- filter(Sexe %in% input$check_sexe,
- date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1],
- CP %in% in_bounds()$Codepos)
- } else
- {
- GHM %>%
- filter(Sexe %in% input$check_sexe,
- GHM %in% input$choice_ghm,
- date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1],
- CP %in% in_bounds()$Codepos)
- }
- })
- output$plot_age <- renderPlot({
- data_age() %>%
- ggplot() +
- aes(x = Age) +
- geom_histogram() +
- scale_x_continuous(limits = c(min_age, max_age)) +
- theme(axis.title = element_blank())
- })
- # Map
-
- # observe({
- # existing <- in_bounds()
- # leafletProxy("map", data = filteredData()) %>%
- # 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)
|