GeoGHM/app.R

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", "Codepos", "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$Codepos) -> insee

# Lecture carte et join avec codes postaux ----
readOGR("communes", "communes-20150101-simpl") -> 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%", step = 30, min = min_date, max = max_date, value = c(max_date - years(1), max_date), animate = animationOptions(interval = 1000))
                                  )
                    )

# Server ----
server <- function(input, output, session)
{
  # Create map
  output$map <- renderLeaflet({
    leaflet(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({
    req(input$map_bounds)

    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],]$Codepos
  })

  # GHM
  data_ghm <- reactive({
    req(input$slider_age, input$check_sexe, input$slider_date, in_bounds())

    GHM %>%
      filter(Age <= input$slider_age[2] & Age >= input$slider_age[1], 
             date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1],
             Codepos %in% in_bounds(),
             Sexe %in% input$check_sexe)
  })

  output$plot_ghm <- renderPlot({
    data_ghm() %>%
      count(GHM, Sexe) %>%
      semi_join(GHM %>% count(GHM) %>% top_n(10) %>% arrange(n), by = "GHM") %>%
      ungroup() %>%
      mutate(GHM = GHM %>% factor(levels = GHM %>% unique)) %>%
      ggplot() +
      aes(x = GHM, y = n, fill = Sexe) +
      geom_bar(stat = "identity") +
      scale_fill_manual(values = c("Homme" = "lightblue", "Femme" = "pink")) +
      coord_flip() +
      theme(axis.title = element_blank(),
            legend.position = "none")
  })

  # Sexe
  data_sexe <- reactive({
    req(input$slider_age, input$slider_date, in_bounds())

    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],
               Codepos %in% in_bounds())
    } 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],
               Codepos %in% in_bounds())
    }
  })

  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({
    req(input$slider_date, input$check_sexe, in_bounds())

    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],
               Codepos %in% in_bounds())  
    } 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],
               Codepos %in% in_bounds())
    }
  })
  output$plot_age <- renderPlot({ 
    data_age() %>%
      ggplot() +
      aes(x = Age, fill = Sexe) +
      geom_histogram(binwidth = 5) +
      scale_fill_manual(values = c("Homme" = "lightblue", "Femme" = "pink")) +
      scale_x_continuous(limits = c(min_age, max_age)) +
      theme(axis.title = element_blank(),
            legend.position = "none")
  })

  # filtered GHM
  filteredData <- reactive({
    req(input$check_sexe, input$slider_age, input$slider_date) #, in_bounds())

    if(input$choice_ghm %>% is.null)
    {
      GHM %>%
        filter(Sexe %in% input$check_sexe,
               Age <= input$slider_age[2] & Age >= input$slider_age[1],
               # Codepos %in% in_bounds(),
               date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1]) %>%
      count(Codepos)
    } else
    {
      GHM %>%
        filter(Sexe %in% input$check_sexe,
               Age <= input$slider_age[2] & Age >= input$slider_age[1],
               GHM %in% input$choice_ghm,
               # Codepos %in% in_bounds(),
               date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1]) %>%
      count(Codepos)
    }
  })

  # Map
  observe({
    req(filteredData())

    comm <- communes
    comm@data %>%
      left_join(filteredData()) -> comm@data

   comm <- comm[!is.na(comm$n),]

   pal <- colorNumeric(palette = topo.colors(100), domain = comm$n, na.color = NA, reverse = T)

    leafletProxy("map", data = comm) %>%
      clearShapes() %>%
      clearControls() %>%
      addPolygons(weight = 1, color = "#222222", opacity = .1, fillOpacity = .3, fillColor = ~pal(n)) %>%
      addLegend(position = "topleft", pal = pal, values = ~n)
  })
}

shinyApp(ui = ui, server = server)