R/mt_creation_pyramide_des_ages.R

In arnaudmilet/medtRucks: Package de préparation et de valorisation des données brutes de mesure d'accès aux soins en France

#' Fonction de création des pyramides des âges pour chaque département (chaque niveau: commune, epci,tvs, dep et cpts si elles sont définies au départ)
#'
#' @param Pop_proj_prepa_ensemble_zonage Tibble généré par le fonction mt_crea_elements_par_dep
#' @param Annee_recensement Numerique correspondant à l'année des données de recensement
#' @param Pop_passe_ensemble_zonage Tibble généré par le fonction mt_crea_elements_par_dep
#'
#' @return Tibble contenant des données démographiques de synthèse ainsi que les pyramides des âges actuelles et projetées pour toutes les zones définies sur un département (commune, epci, territoire de vie et de santé et Département)
#' @seealso \code{\link{mt_crea_elements_par_dep}}
#' @export
#'
#' @examples
#' \dontrun{
#' emplacement_ensemble_data = "data_final/"
#' Annee_recensement = "2018"
#'
#' walk(as.character(c(52,54,55)),function(code_dep){
#'   cat(paste0(code_dep,"\n"))
#'
#'   chemin_data <- paste0(emplacement_ensemble_data,code_dep)
#'   Pop_proj_prepa_ensemble_zonage <- readRDS(paste0(chemin_data,"/Pop_proj_prepa_ensemble_zonage.rds"))
#'   Pop_passe_ensemble_zonage <- readRDS(paste0(chemin_data,"/Pop_passe_ensemble_zonage.rds"))
#'   valeur <- mt_creation_pyramide_des_ages(Pop_proj_prepa_ensemble_zonage,Annee_recensement,Pop_passe_ensemble_zonage)
#'   saveRDS(valeur,paste0(chemin_data,"/Pop_proj_prepa_ensemble_zonage_demo_pyr.rds"))
#' })
#' }
#' @importFrom dplyr group_by mutate filter case_when summarise select mutate_at vars left_join rename
#' @importFrom ggplot2 ggplot aes geom_bar scale_fill_manual geom_step scale_y_continuous theme scale_color_identity coord_flip ylab xlab
#' @importFrom purrr map set_names
#' @importFrom scales percent
#' @importFrom tidyr nest gather spread
mt_creation_pyramide_des_ages <- function(Pop_proj_prepa_ensemble_zonage,Annee_recensement,Pop_passe_ensemble_zonage){
  cat("Pyramide des \u00e2ges\n")

  Pop_proj_prepa_ensemble_zonage_demo_pyr<- Pop_proj_prepa_ensemble_zonage %>%
    dplyr::group_by(codgeo_zonage,typegeo ) %>%
    tidyr::nest() %>%
    dplyr::mutate(
      Pyramide = purrr::map(data, ~ ggplot2::ggplot(., ggplot2::aes(x = Classe_Age, y = Pop_Graph , fill = sexe)) +
                              ggplot2::geom_bar(data = . %>% dplyr::filter(sexe == "Femme"), stat = "identity") +
                              ggplot2::geom_bar(data = . %>% dplyr::filter(sexe == "Homme"), stat = "identity") +
                              ggplot2::scale_fill_manual("Sexe",values = c("#00a1bd","#005D6E"))   +
                              ggplot2::geom_step(data =. %>% dplyr::filter(sexe == "Femme"),
                                        ggplot2::aes(x = ageno,y=Pop_2030_Proj_central_Graph,color="orange")) +
                              ggplot2::geom_step(data =. %>% dplyr::filter(sexe == "Homme"),
                                        ggplot2::aes(x = ageno,y = Pop_2030_Proj_central_Graph,color="orange"))+

                              ggplot2::geom_step(data =. %>% dplyr::filter(sexe == "Femme"),
                                        ggplot2::aes(x = ageno,y=Pop_2030_Proj_basse_Graph,color="red")) +
                              ggplot2::geom_step(data =. %>% dplyr::filter(sexe == "Homme"),
                                        ggplot2::aes(x = ageno,y = Pop_2030_Proj_basse_Graph,color="red"))+

                              ggplot2::geom_step(data =. %>% dplyr::filter(sexe == "Femme"),
                                        ggplot2::aes(x = ageno,y=Pop_2030_Proj_haute_Graph,color="green")) +
                              ggplot2::geom_step(data =. %>% dplyr::filter(sexe == "Homme"),
                                        ggplot2::aes(x = ageno,y = Pop_2030_Proj_haute_Graph,color="green"))+
                              ggplot2::scale_y_continuous(labels = abs)+
                              ggplot2::theme(legend.title.align = 0.5)+
                              ggplot2::scale_color_identity(name = "Scenario\nde\nprojection\n2030",
                                                   breaks = c("orange", "red", "green"),
                                                   labels = c("Central", "Pop. basse", "Pop. haute"),
                                                   guide = "legend")+
                              ggplot2::coord_flip()+
                              ggplot2::ylab("Population")+
                              ggplot2::xlab("Tranche d\'Age")
      )
    )%>%
    dplyr::mutate(
      synthese_demo =purrr::map(data, function(df){
        df %>%
          dplyr::mutate(Classe_Age_Simpli=dplyr::case_when(
            as.numeric(Classe_Age) < 5 ~ "Moins de 20 ans",
            as.numeric(Classe_Age) > 13 ~"Plus de 65 ans",
            TRUE ~"Autres"  )) %>%
          dplyr::group_by(Classe_Age_Simpli) %>%
          dplyr::summarise(
            Pop=sum(Pop),
            Pop_2030_Proj_central =sum(Pop_2030_Proj_central ),
            Pop_2030_Proj_basse =sum(Pop_2030_Proj_basse),
            Pop_2030_Proj_haute =sum(Pop_2030_Proj_haute )
          ) %>%
          tidyr::gather(key="key",value="value",-"Classe_Age_Simpli") %>%
          tidyr::spread(key = "Classe_Age_Simpli",value = "value") %>%
          dplyr::mutate(
            Pop_tot=`Plus de 65 ans`+ Autres +`Moins de 20 ans`,
            `Part Plus de 65 ans`=`Plus de 65 ans`/Pop_tot,
            `Part Moins de 20 ans`=`Moins de 20 ans`/Pop_tot,
            Indice_Viellissement=`Plus de 65 ans`/`Moins de 20 ans`*100) %>%
          dplyr::mutate(
            evol_Pop_tot = scales::percent(Pop_tot/.$Pop_tot[1]-1),
            evol_Moins_20 = scales::percent(`Moins de 20 ans`/.$`Moins de 20 ans`[1]-1),
            evol_Plus_65 = scales::percent(`Plus de 65 ans`/.$`Plus de 65 ans`[1]-1),
            evol_Indice_Viellissement = scales::percent(Indice_Viellissement/.$Indice_Viellissement[1]-1)) %>%
          dplyr::mutate(key=c(Annee_recensement,"Projection 2030 - Scenario pessimiste (population basse)","Projection 2030 - Scenario central","Projection 2030 - Scenario optimiste (population haute)"))
      })
    ) %>%
    dplyr::mutate(
      synthese_demo_ValAbso=purrr::map(synthese_demo,function(df){
        df %>%
          dplyr::select(key,Pop_tot,`Part Moins de 20 ans`,`Part Plus de 65 ans`,Indice_Viellissement) %>%
          dplyr::mutate_at(dplyr::vars(3,4),scales::percent,accuracy=0.1) %>%
          purrr::set_names(c("Annee/Type de projection","Pop. Totale","Part des moins de 20 ans","Part des plus de 65 ans","Indice de vieillissement"))
      }),
      synthese_demo_Evo = purrr::map(synthese_demo,function(df){
        df %>%
          dplyr::select(key,evol_Pop_tot,evol_Moins_20,evol_Plus_65,evol_Indice_Viellissement) %>%
          dplyr::filter(key!=Annee_recensement) %>%
          purrr::set_names(c("Type de projection","Evol. Pop. Totale","Evol. moins de 20 ans","Evol. plus de 65 ans","Evol. Indice de vieillissement"))
      })
    )


  Pop_proj_prepa_ensemble_zonage_demo_pyr <- Pop_proj_prepa_ensemble_zonage_demo_pyr %>%
    dplyr::left_join(Pop_passe_ensemble_zonage %>%
                dplyr::group_by(codgeo_zonage,typegeo) %>%
                tidyr::nest() %>%
                dplyr::rename("Pop_passe"="data"),
              by=c("codgeo_zonage","typegeo")
    )

  return(Pop_proj_prepa_ensemble_zonage_demo_pyr)
}