R/mt_creation_tables_projections_population.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 tables de projection de population à l'échelle communale
#'
#' @param BTX_TD_POP1B data frame contenant les données initiales de l'INSEE
#' @param emplacement_projection_dep_insee_2013_2050 Emplacement des données de projections départementales de l'INSEE collectées
#' @param Annee_recensement Année de recensement des données collectées (BTX_TD_POP1B et base_cc_evol_struct_pop)
#' @param correspondance_age_classe_age data frame de correspondance entre la variable AGED100 du data frame BTX_TD_POP1B et la classe d'âge quinquennal des projections.
#' @param base_cc_evol_struct_pop data frame correspondant au table de l'INSEE d'évolution et structure de la population pour l'année n du recensement
#' @param liste_variables_base_cc_evol_struct_pop Liste des variables de la table base_cc_evol_struct_pop à prendre en compte
#' @param base_cc_evol_struct_pop_n_5 data frame correspondant au table de l'INSEE d'évolution et structure de la population pour l'année n-5 du recensement
#' @param liste_variables_base_cc_evol_struct_pop_n_5 Liste des variables de la table base_cc_evol_struct_pop_n_5 à prendre en compte
#'
#' @return Une liste contenant 3 tables (Pop_proj_prepa_communes,Pop_proj et Pop_passe) utiles à l'exécution de la fonction mt_crea_elements_par_dep
#' @seealso \code{\link{BTX_TD_POP1B}}, \code{\link{projection_2013_2050_55}}, \code{\link{base_cc_evol_struct_pop}}, \code{\link{correspondance_age_classe_age}} et \code{\link{mt_crea_elements_par_dep}}
#' @export
#'
#' @examples
#' \dontrun{
#' BTX_TD_POP1B = readRDS("../data_init/INSEE/2018/BTX_TD_POP1B.rds")
#' Annee_recensement = 2018
#' base_cc_evol_struct_pop <- read_excel("../data_init/INSEE/2018/base-cc-evol-struct-pop-2018.xlsx",
#'                                       skip = 5,sheet = "COM_2018")
#'
#' liste_variables_base_cc_evol_struct_pop=list(
#'   CODGEO="CODGEO",DEP="DEP",POP="P18_POP",H0019="P18_H0019",F0019="P18_F0019",H65P="P18_H65P",F65P="P18_F65P",H2064="P18_H2064",F2064="P18_F2064"
#' )
#'
#' base_cc_evol_struct_pop_n_5 <- read_excel("../data_init/INSEE/2018/base-cc-evol-struct-pop-2018.xlsx",
#'                                           skip = 5,sheet = "COM_2013")
#'
#' liste_variables_base_cc_evol_struct_pop_n_5=list(
#'   CODGEO="CODGEO",DEP="DEP",POP="P13_POP",H0019="P13_H0019",F0019="P13_F0019",H65P="P13_H65P",F65P="P13_F65P",H2064="P13_H2064",F2064="P13_F2064"
#' )
#'
#' correspondance_age_classe_age <- medtRucks::correspondance_age_classe_age
#'
#' emplacement_projection_dep_insee_2013_2050 <- "../data_init/INSEE/projection_2013_2050"
#'
#' valeur <- mt_creation_tables_projections_population(BTX_TD_POP1B=BTX_TD_POP1B,emplacement_projection_dep_insee_2013_2050=emplacement_projection_dep_insee_2013_2050,Annee_recensement=Annee_recensement,correspondance_age_classe_age=correspondance_age_classe_age,base_cc_evol_struct_pop=base_cc_evol_struct_pop,liste_variables_base_cc_evol_struct_pop=liste_variables_base_cc_evol_struct_pop,base_cc_evol_struct_pop_n_5=base_cc_evol_struct_pop_n_5,liste_variables_base_cc_evol_struct_pop_n_5=liste_variables_base_cc_evol_struct_pop_n_5)
#' }
#' @importFrom dplyr mutate left_join group_by summarise filter select
#' @importFrom purrr map_df
#' @importFrom stats setNames
#' @importFrom stringr str_sub
#' @importFrom tidyr gather spread
mt_creation_tables_projections_population <- function(BTX_TD_POP1B,emplacement_projection_dep_insee_2013_2050,Annee_recensement,correspondance_age_classe_age,base_cc_evol_struct_pop,liste_variables_base_cc_evol_struct_pop,base_cc_evol_struct_pop_n_5,liste_variables_base_cc_evol_struct_pop_n_5){
  POP <- BTX_TD_POP1B %>%
    tidyr::gather:gather(key="age_sexe",value="Pop",-c("CODGEO","LIBGEO")) %>%
    dplyr::mutate(
      dep=stringr::str_sub(CODGEO,1,2),
      dep=ifelse(dep=="97",stringr::str_sub(CODGEO,1,3),dep),
      sexe =stringr::str_sub(age_sexe,5,5),
      Age  =stringr::str_sub(age_sexe,14,16),
      An =Annee_recensement,
      sexe=factor(sexe,labels = c("Homme","Femme"))) %>%
    dplyr::left_join(correspondance_age_classe_age,by=c("Age"="AGED100")) %>%
    dplyr::group_by(CODGEO,LIBGEO,dep,sexe,An,Classe_Age) %>%
    dplyr::summarise(Pop=sum(Pop))

  projection_XXXX_2030 <- purrr::map_df(list.files(emplacement_projection_dep_insee_2013_2050,pattern = ".rds",full.names = T),function(x){
    projection_2013_2050_dep <- readRDS(x)

    projection_2013_2050_dep %>%
      dplyr::mutate(
        Age=factor(Age,levels = Classes_Ages),
        sexe=factor(sexe,levels =c("Homme","Femme"))
      ) %>%
      dplyr::filter(proj %in% c("proj1","proj8","proj9") & An %in% c(Annee_recensement,2030)) %>%
      tidyr::spread(key=An,value = Pop) %>%
      dplyr::mutate(evol=.[[length(.)]]/.[[length(.)-1]]) %>%
      dplyr::select(Age,sexe,evol,zone,proj) %>%
      tidyr::spread(key=proj,value=evol)

  })


  Pop_proj <- POP %>%
    dplyr::left_join(projection_XXXX_2030,by=c("dep"="zone","Classe_Age"="Age","sexe")) %>%
    dplyr::mutate(
      Pop_2030_Proj_central=Pop*proj1,
      Pop_2030_Proj_basse=Pop*proj8,
      Pop_2030_Proj_haute=Pop*proj9
    )


  Pop_proj_prepa_communes <- Pop_proj %>%
    dplyr::group_by(CODGEO,dep,sexe,An,Classe_Age) %>%
    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 )
    ) %>%
    dplyr::mutate(
      Pop_Graph = ifelse(sexe=="Homme",-1*Pop,Pop),
      Pop_2030_Proj_central_Graph = ifelse(sexe=="Homme",-1*Pop_2030_Proj_central,Pop_2030_Proj_central),
      Pop_2030_Proj_basse_Graph = ifelse(sexe=="Homme",-1*Pop_2030_Proj_basse,Pop_2030_Proj_basse),
      Pop_2030_Proj_haute_Graph = ifelse(sexe=="Homme",-1*Pop_2030_Proj_haute,Pop_2030_Proj_haute)
    )%>%
    dplyr::mutate(ageno = as.numeric(Classe_Age) - 0.5)%>%
    dplyr::mutate(ageno=ifelse(Classe_Age=="95 ans et +",ageno+1,ageno)) %>%
    dplyr::mutate(typegeo="commune")

  Pop_passe <- base_cc_evol_struct_pop %>%
    dplyr::select(liste_variables_base_cc_evol_struct_pop$CODGEO,liste_variables_base_cc_evol_struct_pop$DEP,liste_variables_base_cc_evol_struct_pop$POP,liste_variables_base_cc_evol_struct_pop$H0019,liste_variables_base_cc_evol_struct_pop$F0019,liste_variables_base_cc_evol_struct_pop$H65P,liste_variables_base_cc_evol_struct_pop$F65P,liste_variables_base_cc_evol_struct_pop$H2064,liste_variables_base_cc_evol_struct_pop$F2064) %>%
    stats::setNames(c("CODGEO","DEP","POP","H0019","F0019","H65P","F65P","H2064","F2064")) %>%
    dplyr::mutate(
      POP_0019=H0019+F0019,
      POP_2064=H2064+F2064,
      POP_65P=H65P+F65P,
      PART_65P=POP_65P/POP,
      PART_0019=POP_0019/POP,
      Indice_Viellissement=POP_65P/POP_2064
    ) %>%
    dplyr::select(CODGEO,DEP,POP,POP_0019,POP_2064,POP_65P,PART_0019,PART_65P,Indice_Viellissement) %>%
    stats::setNames(c("CODGEO","DEP","Pop_tot","Moins de 20 ans","Autres","Plus de 65 ans","Part Moins de 20 ans","Part Plus de 65 ans","Indice_Viellissement")) %>%
    tidyr::gather("key","ANNEE_N",-c("CODGEO","DEP")) %>%
    dplyr::left_join(
      base_cc_evol_struct_pop_n_5 %>%
        dplyr::select(liste_variables_base_cc_evol_struct_pop_n_5$CODGEO,liste_variables_base_cc_evol_struct_pop_n_5$DEP,liste_variables_base_cc_evol_struct_pop_n_5$POP,liste_variables_base_cc_evol_struct_pop_n_5$H0019,liste_variables_base_cc_evol_struct_pop_n_5$F0019,liste_variables_base_cc_evol_struct_pop_n_5$H65P,liste_variables_base_cc_evol_struct_pop_n_5$F65P,liste_variables_base_cc_evol_struct_pop_n_5$H2064,liste_variables_base_cc_evol_struct_pop_n_5$F2064) %>%
        stats::setNames(c("CODGEO","DEP","POP","H0019","F0019","H65P","F65P","H2064","F2064")) %>%
        dplyr::mutate(
          POP_0019=H0019+F0019,
          POP_2064=H2064+F2064,
          POP_65P=H65P+F65P,
          PART_65P=POP_65P/POP,
          PART_0019=POP_0019/POP,
          Indice_Viellissement=POP_65P/POP_2064
        ) %>%
        dplyr::select(CODGEO,DEP,POP,POP_0019,POP_2064,POP_65P,PART_0019,PART_65P,Indice_Viellissement) %>%
        stats::setNames(c("CODGEO","DEP","Pop_tot","Moins de 20 ans","Autres","Plus de 65 ans","Part Moins de 20 ans","Part Plus de 65 ans","Indice_Viellissement")) %>%
        tidyr::gather("key","ANNEE_N_5",-c("CODGEO","DEP")),by=c("CODGEO","DEP","key")
    )

  return(list("Pop_proj_prepa_communes"=Pop_proj_prepa_communes,"Pop_proj"=Pop_proj,"Pop_passe"=Pop_passe))

}