#' Histogramme des effectifs par date/passage (station OU CPP)
#'
#' @param yaml_path Chemin du YAML de connexion Postgres
#' @param station Code Sandre de la station (ou NULL si CPP)
#' @param code_point_prelevement_aspe Code ASPE du point de prélèvement (ou NULL si station)
#' @param annee_debut Année de début
#' @param annee_fin Année de fin (défaut = année courante)
#' @param schema Schéma SQL (défaut "qe")
#' @param bar_width Largeur des barres
#' @param only_with_ipr TRUE pour ne garder que les opérations ayant un IPR
#' @param n_last Nombre maximum de campagnes (dates distinctes)
#'
#' @return ggplot2 ou NULL si aucune donnée
#' @export
plot_effectifs_histogram <- function(
yaml_path,
station = NULL,
code_point_prelevement_aspe = NULL,
annee_debut,
annee_fin = as.numeric(format(Sys.Date(), "%Y")),
schema = "qe",
bar_width = 0.9,
only_with_ipr = FALSE,
n_last = 12
){
require(DBI); require(glue); require(dplyr); require(ggplot2)
# ----------------------------------------------------------------------
# 0) Connexion PG + sécurisation schéma
# ----------------------------------------------------------------------
con <- connect_pg(yaml_path)
on.exit(try(DBI::dbDisconnect(con), silent = TRUE), add = TRUE)
schema_safe <- sanitize_schema(schema)
tbl_lt <- sprintf('"%s".aspe_liste_taxons', schema_safe)
tbl_ops <- sprintf('"%s".aspe_operations', schema_safe)
tbl_sta <- sprintf('"%s".aspe_stations', schema_safe)
tbl_ipr <- sprintf('"%s".aspe_ipr', schema_safe)
# ----------------------------------------------------------------------
# 1) Gestion filtre station / CPP
# ----------------------------------------------------------------------
if (!is.null(station)) {
filtre_sql <- "st.code_station = $1"
param1 <- station
} else if (!is.null(code_point_prelevement_aspe)) {
filtre_sql <- "st.code_point_prelevement_aspe = $1"
param1 <- code_point_prelevement_aspe
} else {
stop("Veuillez fournir station OU code_point_prelevement_aspe.", call. = FALSE)
}
# ----------------------------------------------------------------------
# 2) Filtre IPR optionnel — sécurisé
# ----------------------------------------------------------------------
ipr_filter <- if (isTRUE(only_with_ipr)) glue::glue("
AND EXISTS (
SELECT 1
FROM {tbl_ipr} ipr
WHERE ipr.code_operation = op.code_operation
AND ipr.lib_par = 'IPR'
AND ipr.resultat IS NOT NULL
)
") else ""
# ----------------------------------------------------------------------
# 3) SQL COMPLET — 100% sécurisé
# ----------------------------------------------------------------------
sql <- glue::glue("
WITH base AS (
SELECT
lt.code_operation,
(op.date_operation::timestamptz)::date AS date_op,
CASE
WHEN NULLIF(btrim(lt.numero_passage), '') IS NOT NULL
THEN 'P' || NULLIF(btrim(lt.numero_passage), '')
WHEN NULLIF(btrim(lt.type_points), '') IS NOT NULL
THEN NULLIF(btrim(lt.type_points), '')
ELSE NULL
END AS passage,
NULLIF(btrim(lt.code_lot), '') AS code_lot,
CASE
WHEN btrim(lt.effectif_lot) ~ '^[0-9]+$'
THEN btrim(lt.effectif_lot)::int
ELSE 0
END AS eff
FROM {tbl_lt} lt
JOIN {tbl_ops} op
ON op.code_operation = lt.code_operation
JOIN {tbl_sta} st
ON st.code_point_prelevement_aspe = op.code_point_prelevement_aspe
WHERE {filtre_sql}
AND EXTRACT(YEAR FROM op.date_operation::timestamptz)
BETWEEN $2 AND $3
{ipr_filter}
),
lots_uniques AS (
SELECT DISTINCT ON (code_operation, date_op, passage, code_lot)
code_operation, date_op, passage, code_lot, eff
FROM base
WHERE passage IS NOT NULL AND code_lot IS NOT NULL
ORDER BY code_operation, date_op, passage, code_lot
),
sans_code_lot AS (
SELECT code_operation, date_op, passage, eff
FROM base
WHERE passage IS NOT NULL AND code_lot IS NULL
),
unionee AS (
SELECT code_operation, date_op, passage, eff FROM lots_uniques
UNION ALL
SELECT code_operation, date_op, passage, eff FROM sans_code_lot
)
SELECT date_op, passage, SUM(eff) AS effectif
FROM unionee
GROUP BY date_op, passage
ORDER BY date_op, passage;
")
# ----------------------------------------------------------------------
# 4) Exécution sécurisée
# ----------------------------------------------------------------------
df <- DBI::dbGetQuery(
con,
sql,
params = list(param1, as.integer(annee_debut), as.integer(annee_fin))
)
if (!nrow(df)) return(NULL)
# ----------------------------------------------------------------------
# 5) Préparation des données
# ----------------------------------------------------------------------
df$date_op <- as.Date(df$date_op)
df$label_date <- format(df$date_op, "%d/%m/%y")
# n dernières dates
if (!is.null(n_last) && is.finite(n_last) && n_last > 0) {
last_dates <- unique(df$date_op[order(df$date_op, decreasing = TRUE)])[1:n_last]
df <- df[df$date_op %in% last_dates, , drop = FALSE]
}
levels_x <- unique(df$label_date[order(df$date_op)])
df$label_date <- factor(df$label_date, levels = levels_x, ordered = TRUE)
df$effectif <- as.numeric(df$effectif)
df$passage <- factor(df$passage, levels = rev(unique(df$passage)))
# Total par date
df_tot <- df %>%
group_by(label_date) %>%
summarise(effectif = sum(effectif), .groups="drop")
pal <- scales::hue_pal()(length(levels(df$passage)))
names(pal) <- levels(df$passage)
# ----------------------------------------------------------------------
# 6) Graphique
# ----------------------------------------------------------------------
ggplot2::ggplot(df, aes(x = label_date, y = effectif, fill = passage)) +
geom_col(width = bar_width, colour = "black", linewidth = 0.4) +
geom_text(
data = df_tot,
aes(x = label_date, y = effectif,
label = format(effectif, big.mark = " ", scientific = FALSE)),
inherit.aes = FALSE,
vjust = -0.3, size = 4
) +
scale_y_continuous(expand = expansion(mult = c(0, 0.10))) +
scale_fill_manual(values = pal, name = "Passage") +
labs(title = "Effectif total", x = NULL, y = NULL) +
theme_bw(base_size = 12) +
theme(panel.grid.minor = element_blank(),
axis.text.x = element_text(angle = 90, hjust = 1))
}You’re one inflate from paper to box. Build your package from this
very Rmd using fusen::inflate()
"DESCRIPTION" file has been updated"R/" directory"tests/testthat/" directory"vignettes/" directory