From fb0ea5ab2341b479a98e23a5521259d62ea86557 Mon Sep 17 00:00:00 2001 From: Maxime Wack Date: Tue, 7 Mar 2017 08:18:09 +0100 Subject: [PATCH] Optimisations --- app.R | 180 ++++++++++++++++++++++++++-------------------------------- 1 file changed, 81 insertions(+), 99 deletions(-) diff --git a/app.R b/app.R index ca7fc27..5b613d4 100644 --- a/app.R +++ b/app.R @@ -80,146 +80,128 @@ server <- function(input, output, session) setView(lat = 48.35, lng = 6, zoom = 8) }) +# in GHM + in_ghm <- reactive({ + if (is.null(input$choice_ghm)) + GHM + else + GHM %>% filter(GHM %in% input$choice_ghm) + }) + +# in time + in_time <- reactive({ + req(input$slider_date, in_ghm()) + + filter(in_ghm(), date_entree <= input$slider_date[2] & date_sortie >= input$slider_date[1]) + }) + # in bounds in_bounds <- reactive({ - req(input$map_bounds) + req(input$map_bounds, in_time()) 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 + + codes_pos <- communes[lats >= latrng[1] & lats <= latrng[2] & lngs >= lngrng[1] & lngs <= lngrng[2],]$Codepos + + filter(in_time(), Codepos %in% codes_pos) }) # GHM data_ghm <- reactive({ - req(input$slider_age, input$check_sexe, input$slider_date, in_bounds()) + req(input$slider_age, input$check_sexe, input$slider_date, in_time()) - 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) + in_bounds() %>% + filter(Age <= input$slider_age[2] & Age >= input$slider_age[1], + 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") + data_ghm() %>% + count(GHM, Sexe) %>% + arrange(desc(n)) %>% + .[1:20,] %>% + ungroup() %>% + mutate(GHM = GHM %>% factor(levels = GHM %>% unique %>% rev)) %>% + 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()) + req(input$slider_age, input$slider_date, in_time()) - 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()) - } + in_bounds() %>% + filter(Age <= input$slider_age[2] & Age >= input$slider_age[1]) }) 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()) + 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()) - } + req(input$slider_date, input$check_sexe, in_time()) + + in_bounds() %>% + filter(Sexe %in% input$check_sexe) }) + 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") + 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) - } + req(input$check_sexe, input$slider_age, input$slider_date, in_time()) + + in_time() %>% + filter(Sexe %in% input$check_sexe, + Age <= input$slider_age[2] & Age >= input$slider_age[1]) %>% + count(Codepos) }) # Map observe({ req(filteredData()) - comm <- communes - comm@data %>% - left_join(filteredData()) -> comm@data + comm <- communes + comm@data %>% + left_join(filteredData()) -> comm@data + + comm <- comm[!is.na(comm$n),] - comm <- comm[!is.na(comm$n),] + pal <- colorNumeric(palette = topo.colors(100), domain = comm$n, na.color = NA, reverse = T) - pal <- colorNumeric(palette = topo.colors(100), domain = comm$n, na.color = NA, reverse = T) + leafletProxy("map") %>% + clearShapes() %>% + clearControls() - 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) + leafletProxy("map", data = comm) %>% + addPolygons(weight = 1, color = "#222222", opacity = .1, fillOpacity = .3, fillColor = ~pal(n)) %>% + addLegend(position = "topleft", pal = pal, values = ~n) }) }