inst/extdata/pretraitements.R
In AFB-dataviz/dataviz_pesticides: Explore French pesticide data
library (leaflet)
library (sf)
library (data.table)
library (tidyverse)
library (leaflet.extras)
library(stringr)
library(readxl)
#library(dplyr)
###################################################### LECTURE DES DONNEES TABULEES
################# A partir des donnees transmises par Antonio Andrare (AFB) le 27/05/2019 et format compressé
# on va créer 6 dataframes contenant :
# achats produits par région
# achats substance par région
# achats produits fr
# achats substances fr
# ventes produits
# achats substances
#########Traitements communs aux 6 types de fichiers
# Décompression et listage des fichiers
data_dir <- '../donnees_brutes/zip'
out_dir <- '../donnees_brutes'
dir (data_dir)
zip_files <- list.files(path = data_dir, pattern = "*.zip", full.names = TRUE)
# plyr::ldply(.data = zip_files, .fun = unzip, exdir = out_dir)
file_names <- dir (out_dir)
######### Fonction d'importation pour les fichiers - Import des tables annuelles dont le nom contient
# une chaîne de caractère donnée
setwd (dir = out_dir)
import_cp <- function (chaine_nom = "ACHAT_CP_PRODUIT") {
do.call (rbind, lapply (list.files (path = out_dir, pattern = chaine_nom), fread, header = T, sep = ";", dec = ".",
stringsAsFactors = F, colClasses = c ("amm" = "character", "code_postal_acheteur" = "character")))
}
import_fr <- function (chaine_nom = "ACHAT_CP_PRODUIT") {
do.call (rbind, lapply (list.files (path = out_dir, pattern = chaine_nom), fread, header = T, sep = ";", dec = ".",
stringsAsFactors = F, colClasses = c ("amm" = "character"))) }
add_sum_all_amm <- function (df) {
prov <- df %>%
group_by (annee, code_postal_acheteur) %>%
summarise ()
}
########## application de la fonction
ACHAT_CP_PRODUIT <- import_cp (chaine_nom = "ACHAT_CP_PRODUIT") %>%
mutate (quantite_produit = as.numeric (quantite_produit))
ACHAT_FR_PRODUIT <- import_fr (chaine_nom = "ACHAT_FR_PRODUIT") %>%
mutate (quantite_produit = as.numeric (quantite_produit))
ACHAT_CP_SUBSTANCE <- import_cp (chaine_nom = "ACHAT_CP_SUBSTANCE") %>%
mutate (quantite_substance = as.numeric (quantite_substance)) %>% filter (annee > 2014)
ACHAT_FR_SUBSTANCE <- import_fr (chaine_nom = "ACHAT_FR_SUBSTANCE") %>%
mutate (quantite_substance = as.numeric (quantite_substance))
VENTE_PRODUIT <- import_fr (chaine_nom = "VENTE_PRODUIT")
VENTE_SUBSTANCE <- import_fr (chaine_nom = "VENTE_SUBSTANCE")
###################################################### DATA QUANTITIE SUBSTANCE
#Remplacement des valeurs sous secret "nc" en -1
ACHAT_CP_SUBSTANCE$quantite_substance <- as.numeric(ACHAT_CP_SUBSTANCE$quantite_substance) %>% replace_na(-1)
#Ajout du code département
ACHAT_CP_SUBSTANCE <- mutate (ACHAT_CP_SUBSTANCE, DPT= ifelse (str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3)=='201'|str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3)=='200','2A',
ifelse (str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3)=='202'|str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3)=='206','2B',ifelse (str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,2)=='97',str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3),str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,2)))))
######################### DATA QUANTITE TOTALE ------- DATA ONGLET ACHAT DPT
####### DATA QUANTITE TOTALE / ANNEE
ACHAT_DPT_SUBSTANCE_TOT <- ACHAT_CP_SUBSTANCE %>% filter(quantite_substance>=0) %>% group_by (annee,DPT) %>%
summarise (QTE_SUBS=sum(quantite_substance,na.rm=T)) %>% mutate("T1"= "Quantite totale", "T2" = "Total")
ACHAT_DPT_SUBSTANCE_TOT$annee <- as.character(ACHAT_DPT_SUBSTANCE_TOT$annee)
####### DATA QUANTITE PAR SUBSTANCE / ANNEE
ACHAT_DPT_SUBSTANCE_SUBS <- ACHAT_CP_SUBSTANCE %>% filter(quantite_substance>=0) %>% group_by (annee,DPT,substance) %>%
summarise (QTE_SUBS=sum(quantite_substance,na.rm=T)) %>% mutate("T1"= "Quantite par substance") %>% rename(T2=substance)
ACHAT_DPT_SUBSTANCE_SUBS$annee <- as.character(ACHAT_DPT_SUBSTANCE_SUBS$annee)
## AJOUTER UNE PARITE POUR NE SELECTIONNER QUE LES 5 PREMIERS PAR DEPARTEMENTS
ACHAT_DPT_SUBSTANCE_SUBS<-ACHAT_DPT_SUBSTANCE_SUBS %>%
group_by(DPT,annee) %>%
top_n(5,QTE_SUBS)
####### DATA QUANTITE PAR FONCTION / ANNEE
# read_excel reads both xls and xlsx files
fonction<-read_excel("../donnees_brutes/table_de_passage_CAS_usages.xlsx")
fonction_Reg<-read_excel("../donnees_brutes/Regroupt_des_fonctions.xlsx")
#Le tableau de fonction
ACHAT_DPT_SUBSTANCE_FONCT <- ACHAT_CP_SUBSTANCE %>% filter(quantite_substance>=0) %>% group_by (annee,DPT,cas) %>%
summarise (QTE_SUBS=sum(quantite_substance,na.rm=T)) %>% left_join(fonction,by=c("cas"="CAS")) %>%
left_join(fonction_Reg,by=c("TYPE_USAGE2"="Fonctions"))
#Contrôle que tous les cas ont bien une fonction
#a =ACHAT_DPT_SUBSTANCE_FONCT %>% filter(annee=="2017", DPT=="51") %>% summarise (QTE_SUBS=sum(QTE_SUBS,na.rm=T))
#a <- ACHAT_DPT_SUBSTANCE_FONCT %>% filter(is.na(TYPE_USAGE2 ))
#b <- unique(ungroup(a) %>% select(cas) )
#write.csv(as.data.frame(a),"a.csv")
#write.csv(as.data.frame(b),"b.csv")
ACHAT_DPT_SUBSTANCE_FONCT <- ACHAT_DPT_SUBSTANCE_FONCT %>% group_by (annee,DPT,Fonctions_regroupees) %>%
summarise (QTE_SUBS=sum(QTE_SUBS,na.rm=T)) %>% filter (Fonctions_regroupees != '') %>% mutate("T1"="Fonction") %>% rename(T2=Fonctions_regroupees)
ACHAT_DPT_SUBSTANCE_FONCT$annee <- as.character(ACHAT_DPT_SUBSTANCE_FONCT$annee)
########FUSIONNER LES TABLES EN UNE SEULE ET CONVERSION EN TONNE
ACHAT_DPT_SUBSTANCE_STATS <- rbind(ACHAT_DPT_SUBSTANCE_TOT,ACHAT_DPT_SUBSTANCE_SUBS,ACHAT_DPT_SUBSTANCE_FONCT) %>%
mutate (QTE_SUBS = round(QTE_SUBS / 1000,0))
save(list=c("ACHAT_DPT_SUBSTANCE_STATS"),file="../appli/data/achats_subst_stats.Rdata")
######################### DATA QUANTITE TOTALE ------- DATA ONGLET INDICATEURS
############### CP
##Calcul substance totale
ACHAT_CP_SUBSTANCE_TOT_ALLCP <- ACHAT_CP_SUBSTANCE %>% group_by (annee,code_postal_acheteur,DPT) %>%
summarise (QTE_SUBS=sum(quantite_substance,na.rm=T)) %>% rename(CP = code_postal_acheteur)
##CALAGE SUR LES CP CARTOGRAPHIES
CP_Layer <- dplyr::select(as.data.frame(st_read("geo/codes_postaux_region_wgs84.shp",stringsAsFactors=FALSE)), -LIB,-lat,-long,-DEP,-geometry) %>% rename(CP=ID)
#CP présents dans la couche SIG mais pas dans la BNVD
missing_CP <- CP_Layer %>% anti_join(ACHAT_CP_SUBSTANCE_TOT_ALLCP,by="CP") %>% mutate(x="1")
#Préparation d'une table avec des valeurs nulles pour ces CP
missing_CP <- missing_CP %>%
left_join(data.frame ("x"=c("1","1","1"),
"annee" = c(2015,2016,2017),
stringsAsFactors=FALSE),by="x") %>%
select(-x)
missing_CP$annee <- as.integer(missing_CP$annee)
missing_CP <- missing_CP %>%
mutate (DPT= ifelse (str_sub(missing_CP$CP, 1,3)=='201'|str_sub(missing_CP$CP, 1,3)=='200','2A',
ifelse (str_sub(missing_CP$CP, 1,3)=='202','2B',ifelse (str_sub(missing_CP$CP, 1,2)=='97',str_sub(missing_CP$CP, 1,3),str_sub(missing_CP$CP, 1,2))))) %>%
mutate(QTE_SUBS=0)
##AJOUT DES CP SANS ANNEE
CP <- unique(ungroup(ACHAT_CP_SUBSTANCE_TOT_ALLCP)) %>% mutate(x="1") %>% select(CP,x)
CP_ANNEE <- CP %>% full_join(data.frame ("x"=c("1","1","1"),
"annee" = c(2015,2016,2017)),by="x") %>% select(-x)
CP_ANNEE <- unique(ungroup(CP_ANNEE))
#TABLE TOUS CP / TOUTES ANNEES
ACHAT_CP_SUBSTANCE_TOT_ALLCP <- CP_ANNEE %>% left_join(ACHAT_CP_SUBSTANCE_TOT_ALLCP, by=c("CP","annee"))
ACHAT_CP_SUBSTANCE_TOT_ALLCP$QTE_SUBS <- as.numeric(ACHAT_CP_SUBSTANCE_TOT_ALLCP$QTE_SUBS) %>% replace_na(0)
ACHAT_CP_SUBSTANCE_TOT_ALLCP <- mutate (ACHAT_CP_SUBSTANCE_TOT_ALLCP, DPT= ifelse (str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,3)=='201'|str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,3)=='200','2A',
ifelse (str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,3)=='202','2B',ifelse (str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,2)=='97',str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,3),str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,2)))))
#Ajout des CP manquant à la BNDV
ACHAT_CP_SUBSTANCE_TOT <- CP_Layer %>% left_join(bind_rows(ACHAT_CP_SUBSTANCE_TOT_ALLCP,missing_CP), by="CP")
####### AJOUT SAU ET STH
#Chargement des données sur le RGA 2010 & nettoyage
rga2010 <- fread(file="rga/rga_2010_v2.csv", header = T, sep=";", stringsAsFactors = F)
rga2010$SAU <- as.numeric(rga2010$SAU) %>% replace_na(0)
rga2010$STH <- as.numeric(rga2010$STH) %>% replace_na(0)
#Calcul du prorata des surfaces table de passage CP / Communes
##load data
##CP_map <- st_read(paste0(dir,"geo/codes_postaux_region.shp"))
#COM_map <- st_read(paste0(dir,"geo/COMMUNE.shp"))
#
###Contrôle des sysèmes de projection
##st_crs(CP_map)
#st_crs(COM_map)
##run the intersect function, converting the output to a tibble in the process
##int <- st_union(CP_map, COM_map)
##int$Shape_Area <- st_area(int$geometry)
##shp_out <- st_write(int, "Union_CP_COM.shp")
#Partie réalisée avec ArcGis car ne foncitonne pas avec R
# Intersection communes et CP
# explosion en entité sans multi-partie
#Suppression des artefacts dûs à la différence de contours et de précision des contours communes et CP
# les polygones de moins de 620000m² qui intersectent les labels des communes sont conservées (petites communes)
int <- st_read("geo/Union_CP_COM10_selection.shp")
passage <- data.frame(int) %>%
rename (DEPCOM=NUM_COM,CP=ID)%>%
select(DEPCOM,CP,Shape_Area)%>%
group_by(DEPCOM,CP)%>%
summarise_all(sum) %>% ungroup()
#Calcul de la surface des communes
passage_commune <-passage %>% select(DEPCOM, Shape_Area) %>%
group_by(DEPCOM)%>%
summarise_all(sum) %>%
rename (SURF_COM=Shape_Area)
#Calcul de la surface des CP
passage_CP<-passage %>% select(CP, Shape_Area) %>%
group_by(CP)%>%
summarise_all(sum) %>%
rename (SURF_CP=Shape_Area)
##Jointure ddes surfaces des communes et des CP à la table de passage
passage <-passage %>%
left_join(passage_commune,by="DEPCOM") %>%
left_join(passage_CP,by="CP")
#Calcul du ratio pour passer d'une donnée à la commune au CP
passage <- mutate(passage,COM_To_CP =Shape_Area/SURF_COM*100)
#Calcul du ratio pour passer d'une donnée au CP à la commune
passage <- mutate(passage,CP_To_COM = Shape_Area/SURF_CP*100)
#Renommage du champ shap_area
passage<- passage %>% rename(SURF_INTERCT=Shape_Area)
passage$CP <- as.character(passage$CP)
passage$DEPCOM <- as.character(passage$DEPCOM)
#Jointure avec les données de la table de passage et du RA
RGA_CP_COM <-passage %>%
left_join(rga2010,by="DEPCOM")
#Calcul de la SAU rapportée au CP
RGA_CP_COM <- mutate(RGA_CP_COM,SAU_CP=SAU * COM_To_CP /100) %>%
mutate(STH_CP=STH * COM_To_CP /100) %>%
select (CP,SAU_CP,STH_CP) %>%
group_by(CP) %>%
summarise_all(sum,na.rm = TRUE)
#Ajout de la SAU
ACHAT_CP_SUBSTANCE_TOT <- ACHAT_CP_SUBSTANCE_TOT %>% left_join(RGA_CP_COM,by="CP")
ACHAT_CP_SUBSTANCE_TOT_ALLCP <- ACHAT_CP_SUBSTANCE_TOT_ALLCP %>% left_join(RGA_CP_COM,by="CP")
#Calcul des ratios
#CP sans SAU (-888)
INDIC_CP <- mutate(ACHAT_CP_SUBSTANCE_TOT, QTE_SUBS_SAU= ifelse (ACHAT_CP_SUBSTANCE_TOT$SAU_CP==0 & ACHAT_CP_SUBSTANCE_TOT$QTE_SUBS!=0,-888,round(QTE_SUBS / SAU_CP,2)),
QTE_SUBS_SAU_STH= ifelse ((ACHAT_CP_SUBSTANCE_TOT$SAU_CP - ACHAT_CP_SUBSTANCE_TOT$STH_CP )<=0 & ACHAT_CP_SUBSTANCE_TOT$QTE_SUBS!=0,-888,round(QTE_SUBS / (SAU_CP - STH_CP),2)))
#CP sans glypho (0)
INDIC_CP <- mutate(INDIC_CP,QTE_SUBS_SAU = ifelse (INDIC_CP$QTE_SUBS==0,0,INDIC_CP$QTE_SUBS_SAU),
QTE_SUBS_SAU_STH= ifelse (INDIC_CP$QTE_SUBS==0,0,INDIC_CP$QTE_SUBS_SAU_STH))
#CP sous-secret (-999)
INDIC_CP <- mutate(INDIC_CP,QTE_SUBS_SAU = ifelse (INDIC_CP$QTE_SUBS==-1,-999,INDIC_CP$QTE_SUBS_SAU),
QTE_SUBS_SAU_STH = ifelse (INDIC_CP$QTE_SUBS==-1,-999,INDIC_CP$QTE_SUBS_SAU_STH))%>%
select(CP,annee,QTE_SUBS_SAU,QTE_SUBS_SAU_STH )
INDIC_CP <- data.table::melt(INDIC_CP,id=c("CP","annee"))
library(reshape)
INDIC_CP <- cast(INDIC_CP,CP~variable+annee)
INDIC_CP <- INDIC_CP
############### DEPARTEMENT
#Calcul de la SAU au département
rga2010_DPT <- rga2010 %>% mutate(DPT=ifelse(str_sub(rga2010$DEPCOM, 1,2)=='97',str_sub(rga2010$DEPCOM, 1,3),str_sub(rga2010$DEPCOM, 1,2))) %>%
group_by (DPT) %>% summarise (SAU=sum(SAU,na.rm=T),STH=sum(STH,na.rm=T))
ACHAT_DPT_SUBSTANCE_TOT<- ACHAT_CP_SUBSTANCE_TOT_ALLCP %>% filter(QTE_SUBS >= 0) %>% group_by (annee,DPT) %>%
summarise (QTE_SUBS=sum(QTE_SUBS,na.rm=T)) %>% left_join(rga2010_DPT, by="DPT")
ACHAT_DPT_SUBSTANCE_TOT$SAU <- as.numeric(ACHAT_DPT_SUBSTANCE_TOT$SAU) %>% replace_na(0)
ACHAT_DPT_SUBSTANCE_TOT$STH <- as.numeric(ACHAT_DPT_SUBSTANCE_TOT$STH) %>% replace_na(0)
#DPT sans SAU (-888)
ACHAT_DPT_SUBSTANCE_TOT <- ungroup(ACHAT_DPT_SUBSTANCE_TOT)
INDIC_DPT <- mutate(ACHAT_DPT_SUBSTANCE_TOT, QTE_SUBS_SAU= ifelse (ACHAT_DPT_SUBSTANCE_TOT$SAU==0 & ACHAT_DPT_SUBSTANCE_TOT$QTE_SUBS!=0,-888,round(QTE_SUBS / SAU,2)),
QTE_SUBS_SAU_STH= ifelse ((ACHAT_DPT_SUBSTANCE_TOT$SAU - ACHAT_DPT_SUBSTANCE_TOT$STH )<=0 & ACHAT_DPT_SUBSTANCE_TOT$QTE_SUBS!=0,-888,round(QTE_SUBS / (SAU - STH),2)))
#Mise en forme finale
INDIC_DPT <- INDIC_DPT %>% select(DPT,annee,QTE_SUBS_SAU,QTE_SUBS_SAU_STH )
INDIC_DPT <- data.table::melt(INDIC_DPT,id=c("DPT","annee"))
INDIC_DPT <- cast(INDIC_DPT,DPT~variable+annee)
save(list=c("INDIC_CP","INDIC_DPT"),file="../appli/data/achats_subs_tot.Rdata")
######################################################PREPARTATION FONDS GEO
CP_Layer <- st_read("geo/codes_postaux_region_wgs84.shp",stringsAsFactors=FALSE)
DPT_Layer <- st_read("geo/dep_wgs84.shp",stringsAsFactors=FALSE)
save(list=c("CP_Layer","DPT_Layer"),file="../appli/data/achats_geo_indic.Rdata")
######################################################PREPARTATION FONDS GEO
DPT_Layer <- st_read("geo/dep_wgs84.shp",stringsAsFactors=FALSE)
DPT_Layer_Pt <- st_read("geo/dep_wgs84_Pt.shp",stringsAsFactors=FALSE)
save(list=c("DPT_Layer","DPT_Layer_Pt"),file="../appli/data/achats_geo_stats.Rdata")
######################################################PREPARTATION VARIABLES INTERFACE
###Preparation des zone de liste
#Surface du ratio
Surf_Ref <- c("Surface Agricole Utile" = "SAU", "Surface Agricole Utile - Surface Toujours en herbe" = "SAU_STH")
Periode <- c("2015" = "2015","2016" = "2016","2017" = "2017")
save(list=c("Surf_Ref","Periode"),file="../appli/data/achats_interf_indic.Rdata")
################################################## Export du fichier .Rdata
#rm (data_dir, file_names, out_dir, zip_files, import)
#setwd("../appli")
#save.image("data/data.RData")
AFB-dataviz/dataviz_pesticides documentation built on Nov. 15, 2019, 8:14 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library (leaflet)
library (sf)
library (data.table)
library (tidyverse)
library (leaflet.extras)
library(stringr)
library(readxl)
#library(dplyr)
###################################################### LECTURE DES DONNEES TABULEES
################# A partir des donnees transmises par Antonio Andrare (AFB) le 27/05/2019 et format compressé
# on va créer 6 dataframes contenant :
# achats produits par région
# achats substance par région
# achats produits fr
# achats substances fr
# ventes produits
# achats substances
#########Traitements communs aux 6 types de fichiers
# Décompression et listage des fichiers
data_dir <- '../donnees_brutes/zip'
out_dir <- '../donnees_brutes'
dir (data_dir)
zip_files <- list.files(path = data_dir, pattern = "*.zip", full.names = TRUE)
# plyr::ldply(.data = zip_files, .fun = unzip, exdir = out_dir)
file_names <- dir (out_dir)
######### Fonction d'importation pour les fichiers - Import des tables annuelles dont le nom contient
# une chaîne de caractère donnée
setwd (dir = out_dir)
import_cp <- function (chaine_nom = "ACHAT_CP_PRODUIT") {
do.call (rbind, lapply (list.files (path = out_dir, pattern = chaine_nom), fread, header = T, sep = ";", dec = ".",
stringsAsFactors = F, colClasses = c ("amm" = "character", "code_postal_acheteur" = "character")))
}
import_fr <- function (chaine_nom = "ACHAT_CP_PRODUIT") {
do.call (rbind, lapply (list.files (path = out_dir, pattern = chaine_nom), fread, header = T, sep = ";", dec = ".",
stringsAsFactors = F, colClasses = c ("amm" = "character"))) }
add_sum_all_amm <- function (df) {
prov <- df %>%
group_by (annee, code_postal_acheteur) %>%
summarise ()
}
########## application de la fonction
ACHAT_CP_PRODUIT <- import_cp (chaine_nom = "ACHAT_CP_PRODUIT") %>%
mutate (quantite_produit = as.numeric (quantite_produit))
ACHAT_FR_PRODUIT <- import_fr (chaine_nom = "ACHAT_FR_PRODUIT") %>%
mutate (quantite_produit = as.numeric (quantite_produit))
ACHAT_CP_SUBSTANCE <- import_cp (chaine_nom = "ACHAT_CP_SUBSTANCE") %>%
mutate (quantite_substance = as.numeric (quantite_substance)) %>% filter (annee > 2014)
ACHAT_FR_SUBSTANCE <- import_fr (chaine_nom = "ACHAT_FR_SUBSTANCE") %>%
mutate (quantite_substance = as.numeric (quantite_substance))
VENTE_PRODUIT <- import_fr (chaine_nom = "VENTE_PRODUIT")
VENTE_SUBSTANCE <- import_fr (chaine_nom = "VENTE_SUBSTANCE")
###################################################### DATA QUANTITIE SUBSTANCE
#Remplacement des valeurs sous secret "nc" en -1
ACHAT_CP_SUBSTANCE$quantite_substance <- as.numeric(ACHAT_CP_SUBSTANCE$quantite_substance) %>% replace_na(-1)
#Ajout du code département
ACHAT_CP_SUBSTANCE <- mutate (ACHAT_CP_SUBSTANCE, DPT= ifelse (str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3)=='201'|str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3)=='200','2A',
ifelse (str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3)=='202'|str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3)=='206','2B',ifelse (str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,2)=='97',str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,3),str_sub(ACHAT_CP_SUBSTANCE$code_postal_acheteur, 1,2)))))
######################### DATA QUANTITE TOTALE ------- DATA ONGLET ACHAT DPT
####### DATA QUANTITE TOTALE / ANNEE
ACHAT_DPT_SUBSTANCE_TOT <- ACHAT_CP_SUBSTANCE %>% filter(quantite_substance>=0) %>% group_by (annee,DPT) %>%
summarise (QTE_SUBS=sum(quantite_substance,na.rm=T)) %>% mutate("T1"= "Quantite totale", "T2" = "Total")
ACHAT_DPT_SUBSTANCE_TOT$annee <- as.character(ACHAT_DPT_SUBSTANCE_TOT$annee)
####### DATA QUANTITE PAR SUBSTANCE / ANNEE
ACHAT_DPT_SUBSTANCE_SUBS <- ACHAT_CP_SUBSTANCE %>% filter(quantite_substance>=0) %>% group_by (annee,DPT,substance) %>%
summarise (QTE_SUBS=sum(quantite_substance,na.rm=T)) %>% mutate("T1"= "Quantite par substance") %>% rename(T2=substance)
ACHAT_DPT_SUBSTANCE_SUBS$annee <- as.character(ACHAT_DPT_SUBSTANCE_SUBS$annee)
## AJOUTER UNE PARITE POUR NE SELECTIONNER QUE LES 5 PREMIERS PAR DEPARTEMENTS
ACHAT_DPT_SUBSTANCE_SUBS<-ACHAT_DPT_SUBSTANCE_SUBS %>%
group_by(DPT,annee) %>%
top_n(5,QTE_SUBS)
####### DATA QUANTITE PAR FONCTION / ANNEE
# read_excel reads both xls and xlsx files
fonction<-read_excel("../donnees_brutes/table_de_passage_CAS_usages.xlsx")
fonction_Reg<-read_excel("../donnees_brutes/Regroupt_des_fonctions.xlsx")
#Le tableau de fonction
ACHAT_DPT_SUBSTANCE_FONCT <- ACHAT_CP_SUBSTANCE %>% filter(quantite_substance>=0) %>% group_by (annee,DPT,cas) %>%
summarise (QTE_SUBS=sum(quantite_substance,na.rm=T)) %>% left_join(fonction,by=c("cas"="CAS")) %>%
left_join(fonction_Reg,by=c("TYPE_USAGE2"="Fonctions"))
#Contrôle que tous les cas ont bien une fonction
#a =ACHAT_DPT_SUBSTANCE_FONCT %>% filter(annee=="2017", DPT=="51") %>% summarise (QTE_SUBS=sum(QTE_SUBS,na.rm=T))
#a <- ACHAT_DPT_SUBSTANCE_FONCT %>% filter(is.na(TYPE_USAGE2 ))
#b <- unique(ungroup(a) %>% select(cas) )
#write.csv(as.data.frame(a),"a.csv")
#write.csv(as.data.frame(b),"b.csv")
ACHAT_DPT_SUBSTANCE_FONCT <- ACHAT_DPT_SUBSTANCE_FONCT %>% group_by (annee,DPT,Fonctions_regroupees) %>%
summarise (QTE_SUBS=sum(QTE_SUBS,na.rm=T)) %>% filter (Fonctions_regroupees != '') %>% mutate("T1"="Fonction") %>% rename(T2=Fonctions_regroupees)
ACHAT_DPT_SUBSTANCE_FONCT$annee <- as.character(ACHAT_DPT_SUBSTANCE_FONCT$annee)
########FUSIONNER LES TABLES EN UNE SEULE ET CONVERSION EN TONNE
ACHAT_DPT_SUBSTANCE_STATS <- rbind(ACHAT_DPT_SUBSTANCE_TOT,ACHAT_DPT_SUBSTANCE_SUBS,ACHAT_DPT_SUBSTANCE_FONCT) %>%
mutate (QTE_SUBS = round(QTE_SUBS / 1000,0))
save(list=c("ACHAT_DPT_SUBSTANCE_STATS"),file="../appli/data/achats_subst_stats.Rdata")
######################### DATA QUANTITE TOTALE ------- DATA ONGLET INDICATEURS
############### CP
##Calcul substance totale
ACHAT_CP_SUBSTANCE_TOT_ALLCP <- ACHAT_CP_SUBSTANCE %>% group_by (annee,code_postal_acheteur,DPT) %>%
summarise (QTE_SUBS=sum(quantite_substance,na.rm=T)) %>% rename(CP = code_postal_acheteur)
##CALAGE SUR LES CP CARTOGRAPHIES
CP_Layer <- dplyr::select(as.data.frame(st_read("geo/codes_postaux_region_wgs84.shp",stringsAsFactors=FALSE)), -LIB,-lat,-long,-DEP,-geometry) %>% rename(CP=ID)
#CP présents dans la couche SIG mais pas dans la BNVD
missing_CP <- CP_Layer %>% anti_join(ACHAT_CP_SUBSTANCE_TOT_ALLCP,by="CP") %>% mutate(x="1")
#Préparation d'une table avec des valeurs nulles pour ces CP
missing_CP <- missing_CP %>%
left_join(data.frame ("x"=c("1","1","1"),
"annee" = c(2015,2016,2017),
stringsAsFactors=FALSE),by="x") %>%
select(-x)
missing_CP$annee <- as.integer(missing_CP$annee)
missing_CP <- missing_CP %>%
mutate (DPT= ifelse (str_sub(missing_CP$CP, 1,3)=='201'|str_sub(missing_CP$CP, 1,3)=='200','2A',
ifelse (str_sub(missing_CP$CP, 1,3)=='202','2B',ifelse (str_sub(missing_CP$CP, 1,2)=='97',str_sub(missing_CP$CP, 1,3),str_sub(missing_CP$CP, 1,2))))) %>%
mutate(QTE_SUBS=0)
##AJOUT DES CP SANS ANNEE
CP <- unique(ungroup(ACHAT_CP_SUBSTANCE_TOT_ALLCP)) %>% mutate(x="1") %>% select(CP,x)
CP_ANNEE <- CP %>% full_join(data.frame ("x"=c("1","1","1"),
"annee" = c(2015,2016,2017)),by="x") %>% select(-x)
CP_ANNEE <- unique(ungroup(CP_ANNEE))
#TABLE TOUS CP / TOUTES ANNEES
ACHAT_CP_SUBSTANCE_TOT_ALLCP <- CP_ANNEE %>% left_join(ACHAT_CP_SUBSTANCE_TOT_ALLCP, by=c("CP","annee"))
ACHAT_CP_SUBSTANCE_TOT_ALLCP$QTE_SUBS <- as.numeric(ACHAT_CP_SUBSTANCE_TOT_ALLCP$QTE_SUBS) %>% replace_na(0)
ACHAT_CP_SUBSTANCE_TOT_ALLCP <- mutate (ACHAT_CP_SUBSTANCE_TOT_ALLCP, DPT= ifelse (str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,3)=='201'|str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,3)=='200','2A',
ifelse (str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,3)=='202','2B',ifelse (str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,2)=='97',str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,3),str_sub(ACHAT_CP_SUBSTANCE_TOT_ALLCP$CP, 1,2)))))
#Ajout des CP manquant à la BNDV
ACHAT_CP_SUBSTANCE_TOT <- CP_Layer %>% left_join(bind_rows(ACHAT_CP_SUBSTANCE_TOT_ALLCP,missing_CP), by="CP")
####### AJOUT SAU ET STH
#Chargement des données sur le RGA 2010 & nettoyage
rga2010 <- fread(file="rga/rga_2010_v2.csv", header = T, sep=";", stringsAsFactors = F)
rga2010$SAU <- as.numeric(rga2010$SAU) %>% replace_na(0)
rga2010$STH <- as.numeric(rga2010$STH) %>% replace_na(0)
#Calcul du prorata des surfaces table de passage CP / Communes
##load data
##CP_map <- st_read(paste0(dir,"geo/codes_postaux_region.shp"))
#COM_map <- st_read(paste0(dir,"geo/COMMUNE.shp"))
#
###Contrôle des sysèmes de projection
##st_crs(CP_map)
#st_crs(COM_map)
##run the intersect function, converting the output to a tibble in the process
##int <- st_union(CP_map, COM_map)
##int$Shape_Area <- st_area(int$geometry)
##shp_out <- st_write(int, "Union_CP_COM.shp")
#Partie réalisée avec ArcGis car ne foncitonne pas avec R
# Intersection communes et CP
# explosion en entité sans multi-partie
#Suppression des artefacts dûs à la différence de contours et de précision des contours communes et CP
# les polygones de moins de 620000m² qui intersectent les labels des communes sont conservées (petites communes)
int <- st_read("geo/Union_CP_COM10_selection.shp")
passage <- data.frame(int) %>%
rename (DEPCOM=NUM_COM,CP=ID)%>%
select(DEPCOM,CP,Shape_Area)%>%
group_by(DEPCOM,CP)%>%
summarise_all(sum) %>% ungroup()
#Calcul de la surface des communes
passage_commune <-passage %>% select(DEPCOM, Shape_Area) %>%
group_by(DEPCOM)%>%
summarise_all(sum) %>%
rename (SURF_COM=Shape_Area)
#Calcul de la surface des CP
passage_CP<-passage %>% select(CP, Shape_Area) %>%
group_by(CP)%>%
summarise_all(sum) %>%
rename (SURF_CP=Shape_Area)
##Jointure ddes surfaces des communes et des CP à la table de passage
passage <-passage %>%
left_join(passage_commune,by="DEPCOM") %>%
left_join(passage_CP,by="CP")
#Calcul du ratio pour passer d'une donnée à la commune au CP
passage <- mutate(passage,COM_To_CP =Shape_Area/SURF_COM*100)
#Calcul du ratio pour passer d'une donnée au CP à la commune
passage <- mutate(passage,CP_To_COM = Shape_Area/SURF_CP*100)
#Renommage du champ shap_area
passage<- passage %>% rename(SURF_INTERCT=Shape_Area)
passage$CP <- as.character(passage$CP)
passage$DEPCOM <- as.character(passage$DEPCOM)
#Jointure avec les données de la table de passage et du RA
RGA_CP_COM <-passage %>%
left_join(rga2010,by="DEPCOM")
#Calcul de la SAU rapportée au CP
RGA_CP_COM <- mutate(RGA_CP_COM,SAU_CP=SAU * COM_To_CP /100) %>%
mutate(STH_CP=STH * COM_To_CP /100) %>%
select (CP,SAU_CP,STH_CP) %>%
group_by(CP) %>%
summarise_all(sum,na.rm = TRUE)
#Ajout de la SAU
ACHAT_CP_SUBSTANCE_TOT <- ACHAT_CP_SUBSTANCE_TOT %>% left_join(RGA_CP_COM,by="CP")
ACHAT_CP_SUBSTANCE_TOT_ALLCP <- ACHAT_CP_SUBSTANCE_TOT_ALLCP %>% left_join(RGA_CP_COM,by="CP")
#Calcul des ratios
#CP sans SAU (-888)
INDIC_CP <- mutate(ACHAT_CP_SUBSTANCE_TOT, QTE_SUBS_SAU= ifelse (ACHAT_CP_SUBSTANCE_TOT$SAU_CP==0 & ACHAT_CP_SUBSTANCE_TOT$QTE_SUBS!=0,-888,round(QTE_SUBS / SAU_CP,2)),
QTE_SUBS_SAU_STH= ifelse ((ACHAT_CP_SUBSTANCE_TOT$SAU_CP - ACHAT_CP_SUBSTANCE_TOT$STH_CP )<=0 & ACHAT_CP_SUBSTANCE_TOT$QTE_SUBS!=0,-888,round(QTE_SUBS / (SAU_CP - STH_CP),2)))
#CP sans glypho (0)
INDIC_CP <- mutate(INDIC_CP,QTE_SUBS_SAU = ifelse (INDIC_CP$QTE_SUBS==0,0,INDIC_CP$QTE_SUBS_SAU),
QTE_SUBS_SAU_STH= ifelse (INDIC_CP$QTE_SUBS==0,0,INDIC_CP$QTE_SUBS_SAU_STH))
#CP sous-secret (-999)
INDIC_CP <- mutate(INDIC_CP,QTE_SUBS_SAU = ifelse (INDIC_CP$QTE_SUBS==-1,-999,INDIC_CP$QTE_SUBS_SAU),
QTE_SUBS_SAU_STH = ifelse (INDIC_CP$QTE_SUBS==-1,-999,INDIC_CP$QTE_SUBS_SAU_STH))%>%
select(CP,annee,QTE_SUBS_SAU,QTE_SUBS_SAU_STH )
INDIC_CP <- data.table::melt(INDIC_CP,id=c("CP","annee"))
library(reshape)
INDIC_CP <- cast(INDIC_CP,CP~variable+annee)
INDIC_CP <- INDIC_CP
############### DEPARTEMENT
#Calcul de la SAU au département
rga2010_DPT <- rga2010 %>% mutate(DPT=ifelse(str_sub(rga2010$DEPCOM, 1,2)=='97',str_sub(rga2010$DEPCOM, 1,3),str_sub(rga2010$DEPCOM, 1,2))) %>%
group_by (DPT) %>% summarise (SAU=sum(SAU,na.rm=T),STH=sum(STH,na.rm=T))
ACHAT_DPT_SUBSTANCE_TOT<- ACHAT_CP_SUBSTANCE_TOT_ALLCP %>% filter(QTE_SUBS >= 0) %>% group_by (annee,DPT) %>%
summarise (QTE_SUBS=sum(QTE_SUBS,na.rm=T)) %>% left_join(rga2010_DPT, by="DPT")
ACHAT_DPT_SUBSTANCE_TOT$SAU <- as.numeric(ACHAT_DPT_SUBSTANCE_TOT$SAU) %>% replace_na(0)
ACHAT_DPT_SUBSTANCE_TOT$STH <- as.numeric(ACHAT_DPT_SUBSTANCE_TOT$STH) %>% replace_na(0)
#DPT sans SAU (-888)
ACHAT_DPT_SUBSTANCE_TOT <- ungroup(ACHAT_DPT_SUBSTANCE_TOT)
INDIC_DPT <- mutate(ACHAT_DPT_SUBSTANCE_TOT, QTE_SUBS_SAU= ifelse (ACHAT_DPT_SUBSTANCE_TOT$SAU==0 & ACHAT_DPT_SUBSTANCE_TOT$QTE_SUBS!=0,-888,round(QTE_SUBS / SAU,2)),
QTE_SUBS_SAU_STH= ifelse ((ACHAT_DPT_SUBSTANCE_TOT$SAU - ACHAT_DPT_SUBSTANCE_TOT$STH )<=0 & ACHAT_DPT_SUBSTANCE_TOT$QTE_SUBS!=0,-888,round(QTE_SUBS / (SAU - STH),2)))
#Mise en forme finale
INDIC_DPT <- INDIC_DPT %>% select(DPT,annee,QTE_SUBS_SAU,QTE_SUBS_SAU_STH )
INDIC_DPT <- data.table::melt(INDIC_DPT,id=c("DPT","annee"))
INDIC_DPT <- cast(INDIC_DPT,DPT~variable+annee)
save(list=c("INDIC_CP","INDIC_DPT"),file="../appli/data/achats_subs_tot.Rdata")
######################################################PREPARTATION FONDS GEO
CP_Layer <- st_read("geo/codes_postaux_region_wgs84.shp",stringsAsFactors=FALSE)
DPT_Layer <- st_read("geo/dep_wgs84.shp",stringsAsFactors=FALSE)
save(list=c("CP_Layer","DPT_Layer"),file="../appli/data/achats_geo_indic.Rdata")
######################################################PREPARTATION FONDS GEO
DPT_Layer <- st_read("geo/dep_wgs84.shp",stringsAsFactors=FALSE)
DPT_Layer_Pt <- st_read("geo/dep_wgs84_Pt.shp",stringsAsFactors=FALSE)
save(list=c("DPT_Layer","DPT_Layer_Pt"),file="../appli/data/achats_geo_stats.Rdata")
######################################################PREPARTATION VARIABLES INTERFACE
###Preparation des zone de liste
#Surface du ratio
Surf_Ref <- c("Surface Agricole Utile" = "SAU", "Surface Agricole Utile - Surface Toujours en herbe" = "SAU_STH")
Periode <- c("2015" = "2015","2016" = "2016","2017" = "2017")
save(list=c("Surf_Ref","Periode"),file="../appli/data/achats_interf_indic.Rdata")
################################################## Export du fichier .Rdata
#rm (data_dir, file_names, out_dir, zip_files, import)
#setwd("../appli")
#save.image("data/data.RData")
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.