text_lines <- c(
"NÁVRH TEXTU NA SLIDE",
"--------------------",
"• Dětská populace v novějších letech zůstává relativně vysoká.",
"• Počet PLDD při použití klouzavého průměru spíše stagnuje až mírně klesá.",
"• Počet dětí na 1 PLDD proto roste a ukazuje zesilující tlak na kapacitu péče.",
"",
paste0("Báze indexu: ", base_year, " = 100"),
paste0("Děti 0–18: ", fmt_int(value_base_deti), " → ", fmt_int(value_last_deti)),
paste0("PLDD (", ma_window, "letý MA): ", fmt_dec(value_base_pldd, 0.1), " → ", fmt_dec(value_last_pldd, 0.1)),
paste0("Děti na 1 PLDD: ", fmt_dec(value_base_ratio, 0.1), " → ", fmt_dec(value_last_ratio, 0.1))
)
txt_file <- file.path(out_dir, "slide_poznamky_3_linky_prezentace.txt")
writeLines(text_lines, txt_file, useBytes = TRUE)
cat("\nHotovo.\n")
cat("PNG:  ", png_file, "\n", sep = "")
cat("PDF:  ", pdf_file, "\n", sep = "")
cat("CSV:  ", csv_file, "\n", sep = "")
cat("XLSX: ", xlsx_file, "\n", sep = "")
cat("TXT:  ", txt_file, "\n", sep = "")
rm(list = ls(all.names = TRUE))
gc()
cat("\014")
graphics.off()
# =========================================================
# SLIDE: VÝVOJ DĚTSKÉ POPULACE, POČTU PLDD A DĚTÍ NA 1 PLDD
# ---------------------------------------------------------
# VERZE PRO PREZENTACI:
# - větší písmo
# - silnější linky
# - méně rušivých prvků
# - přímé popisky na konci křivek
# - bez legendy
# - pouze jeden název obrázku nahoře nad grafem
# - název i podnadpis vycentrované
# - dole vpravo kurzivou zdroj
# - export v poměru 16:9
# =========================================================
# =========================
# 0) Balíčky
# =========================
needed_packages <- c(
"readxl", "readr", "dplyr", "stringr", "tidyr",
"ggplot2", "scales", "ggrepel", "openxlsx", "tibble", "grid"
)
to_install <- needed_packages[!needed_packages %in% rownames(installed.packages())]
if (length(to_install) > 0) install.packages(to_install)
suppressPackageStartupMessages({
library(readxl)
library(readr)
library(dplyr)
library(stringr)
library(tidyr)
library(ggplot2)
library(scales)
library(ggrepel)
library(openxlsx)
library(tibble)
library(grid)
})
options(readxl.show_progress = FALSE)
# =========================
# 1) Cesty a nastavení
# =========================
file_demo  <- "C:/Users/karel/Desktop/struktura-obyvatelstva/cr_1945_2024.xlsx"
file_pldd  <- "C:/Users/karel/Desktop/vyvoj-pediatru/pldd_1992_2024.csv"
sheet_demo <- "jed"
out_dir <- "C:/Users/karel/Desktop/4"
if (!dir.exists(out_dir)) dir.create(out_dir, recursive = TRUE)
if (!file.exists(file_demo)) stop("Demografický XLSX soubor neexistuje:\n", file_demo)
if (!file.exists(file_pldd)) stop("CSV soubor s PLDD neexistuje:\n", file_pldd)
preferred_base_year <- 2010
ma_window <- 3
# =========================
# 2) Popisky řad
# =========================
label_deti  <- "Děti 0–18 let"
label_pldd  <- paste0("PLDD (", ma_window, "letý klouzavý průměr)")
label_ratio <- "Dětí 0–18 na 1 PLDD"
# =========================
# 3) Pomocné funkce
# =========================
to_num <- function(x) {
x <- as.character(x)
x <- str_replace_all(x, "\\u00A0", " ")
x <- str_replace_all(x, " ", "")
x <- str_replace_all(x, ",", ".")
x[x %in% c("", "NA", "-", "NULL")] <- NA
suppressWarnings(as.numeric(x))
}
extract_year_from_colname <- function(x) {
x <- as.character(x)
num_txt <- str_extract(x, "\\d+")
num_val <- suppressWarnings(as.numeric(num_txt))
if (!is.na(num_val) && num_val > 10000 && num_val < 60000) {
dt <- as.Date(num_val, origin = "1899-12-30")
yr <- suppressWarnings(as.integer(format(dt, "%Y")))
if (!is.na(yr) && yr >= 1945 && yr <= 2024) return(yr)
}
hit <- str_extract(x, "(19|20)\\d{2}")
if (is.na(hit)) return(NA_integer_)
yr <- suppressWarnings(as.integer(hit))
if (is.na(yr) || yr < 1945 || yr > 2024) return(NA_integer_)
yr
}
safe_pull_one <- function(x, name = "hodnota") {
if (length(x) == 0 || all(is.na(x))) stop("Chybí hodnota: ", name)
x[1]
}
fmt_int <- function(x) {
number(x, accuracy = 1, big.mark = " ", decimal.mark = ",")
}
fmt_dec <- function(x, acc = 0.1) {
number(x, accuracy = acc, big.mark = " ", decimal.mark = ",")
}
safe_ratio <- function(num, den) {
ifelse(is.na(num) | is.na(den) | den == 0, NA_real_, num / den)
}
moving_average_trailing <- function(x, n = 3) {
out <- rep(NA_real_, length(x))
for (i in seq_along(x)) {
j <- max(1, i - n + 1)
out[i] <- mean(x[j:i], na.rm = TRUE)
}
out
}
fill_linear_with_edge_trend <- function(years, values, fit_points = 5) {
y <- values
ok <- which(!is.na(y))
if (length(ok) < 2) {
stop("Pro dopočet řady PLDD jsou potřeba alespoň 2 nenulové / ne-NA body.")
}
y_interp <- approx(
x = years[ok],
y = y[ok],
xout = years,
method = "linear",
rule = 1
)$y
idx_left <- which(years < min(years[ok]))
if (length(idx_left) > 0) {
k_left <- head(ok, min(fit_points, length(ok)))
left_df <- data.frame(rok = years[k_left], hodnota = y[k_left])
mod_left <- lm(hodnota ~ rok, data = left_df)
y_interp[idx_left] <- predict(mod_left, newdata = data.frame(rok = years[idx_left]))
}
idx_right <- which(years > max(years[ok]))
if (length(idx_right) > 0) {
k_right <- tail(ok, min(fit_points, length(ok)))
right_df <- data.frame(rok = years[k_right], hodnota = y[k_right])
mod_right <- lm(hodnota ~ rok, data = right_df)
y_interp[idx_right] <- predict(mod_right, newdata = data.frame(rok = years[idx_right]))
}
as.numeric(y_interp)
}
# =========================
# 4) Demografie 0–18 let
# =========================
raw_demo <- read_excel(
file_demo,
sheet = sheet_demo,
col_names = TRUE,
.name_repair = "minimal"
)
col_pohlavi <- names(raw_demo)[1]
col_vek     <- names(raw_demo)[2]
year_cols <- names(raw_demo)[sapply(names(raw_demo), function(x) {
yr <- extract_year_from_colname(x)
!is.na(yr)
})]
year_map <- tibble(
col_name = year_cols,
rok = sapply(year_cols, extract_year_from_colname)
) %>%
distinct(rok, .keep_all = TRUE) %>%
arrange(rok)
if (nrow(year_map) < 50) {
stop("Bylo nalezeno příliš málo roků v demografickém souboru.")
}
demo_df <- raw_demo %>%
transmute(
pohlavi = str_squish(as.character(.data[[col_pohlavi]])),
vek_raw = str_squish(as.character(.data[[col_vek]])),
vek_num = suppressWarnings(as.integer(vek_raw)),
!!!setNames(
lapply(year_map$col_name, function(cl) to_num(raw_demo[[cl]])),
paste0("rok_", year_map$rok)
)
) %>%
filter(!is.na(vek_num), vek_num >= 0, vek_num <= 18)
demo_0_18 <- demo_df %>%
group_by(vek_num) %>%
summarise(
across(starts_with("rok_"), ~ sum(.x, na.rm = TRUE)),
.groups = "drop"
) %>%
pivot_longer(
cols = starts_with("rok_"),
names_to = "rok",
values_to = "osoby_0_18"
) %>%
mutate(rok = as.integer(str_remove(rok, "rok_"))) %>%
group_by(rok) %>%
summarise(osoby_0_18 = sum(osoby_0_18, na.rm = TRUE), .groups = "drop") %>%
arrange(rok)
# =========================
# 5) PLDD: načtení a dopočet plné řady
# =========================
pldd_raw <- read_csv(
file_pldd,
na = c("", "NA"),
show_col_types = FALSE
) %>%
mutate(across(everything(), ~ if (is.character(.x)) str_squish(.x) else .x)) %>%
mutate(
Rok = as.integer(to_num(Rok)),
Pediatri_FTE_rocenky = to_num(Pediatri_FTE_rocenky),
Ordinace_rocenky = to_num(Ordinace_rocenky),
Ordinace_statistika_CSU_UZIS = to_num(Ordinace_statistika_CSU_UZIS)
) %>%
arrange(Rok)
years_full <- tibble(Rok = 1993:2024)
pldd_full <- years_full %>%
left_join(pldd_raw %>% select(Rok, Pediatri_FTE_rocenky), by = "Rok") %>%
arrange(Rok)
pldd_full <- pldd_full %>%
mutate(
pldd_fte_dopocteno = fill_linear_with_edge_trend(
years = Rok,
values = Pediatri_FTE_rocenky,
fit_points = 5
),
pldd_fte_ma = moving_average_trailing(pldd_fte_dopocteno, n = ma_window)
)
# =========================
# 6) Spojení dat a výpočet 3 řad
# =========================
slide_df <- years_full %>%
left_join(demo_0_18, by = c("Rok" = "rok")) %>%
left_join(
pldd_full %>% select(Rok, Pediatri_FTE_rocenky, pldd_fte_dopocteno, pldd_fte_ma),
by = "Rok"
) %>%
mutate(
deti_na_pldd = safe_ratio(osoby_0_18, pldd_fte_ma)
) %>%
arrange(Rok)
valid_base_years <- slide_df %>%
filter(
!is.na(osoby_0_18),
!is.na(pldd_fte_ma),
!is.na(deti_na_pldd)
) %>%
pull(Rok)
if (length(valid_base_years) == 0) {
stop("Nenalezen žádný rok vhodný pro bázi indexu.")
}
base_year <- if (preferred_base_year %in% valid_base_years) preferred_base_year else min(valid_base_years)
base_children <- slide_df %>%
filter(Rok == base_year) %>%
pull(osoby_0_18) %>%
safe_pull_one(paste0("počet dětí v roce ", base_year))
base_pldd_ma <- slide_df %>%
filter(Rok == base_year) %>%
pull(pldd_fte_ma) %>%
safe_pull_one(paste0("PLDD MA v roce ", base_year))
base_ratio <- slide_df %>%
filter(Rok == base_year) %>%
pull(deti_na_pldd) %>%
safe_pull_one(paste0("děti na PLDD v roce ", base_year))
slide_df <- slide_df %>%
mutate(
index_deti = osoby_0_18 / base_children * 100,
index_pldd = pldd_fte_ma / base_pldd_ma * 100,
index_deti_na_pldd = deti_na_pldd / base_ratio * 100
)
# =========================
# 7) Data pro graf
# =========================
plot_df <- slide_df %>%
select(Rok, index_deti, index_pldd, index_deti_na_pldd) %>%
pivot_longer(
cols = c(index_deti, index_pldd, index_deti_na_pldd),
names_to = "rada",
values_to = "index"
) %>%
mutate(
rada = case_when(
rada == "index_deti" ~ label_deti,
rada == "index_pldd" ~ label_pldd,
rada == "index_deti_na_pldd" ~ label_ratio,
TRUE ~ rada
),
rada = factor(rada, levels = c(label_deti, label_pldd, label_ratio))
)
last_year <- max(plot_df$Rok, na.rm = TRUE)
last_values <- slide_df %>%
filter(Rok == last_year) %>%
transmute(
Rok,
index_deti,
index_pldd,
index_deti_na_pldd,
osoby_0_18,
pldd_fte_ma,
deti_na_pldd
)
last_points <- tibble(
Rok = c(last_year, last_year, last_year),
rada = factor(c(label_deti, label_pldd, label_ratio), levels = c(label_deti, label_pldd, label_ratio)),
index = c(last_values$index_deti, last_values$index_pldd, last_values$index_deti_na_pldd),
label = c(
paste0("Děti: ", fmt_int(last_values$osoby_0_18)),
paste0("PLDD: ", fmt_dec(last_values$pldd_fte_ma, 0.1)),
paste0("Dětí / PLDD: ", fmt_dec(last_values$deti_na_pldd, 0.1))
)
)
color_values <- setNames(
c("#1f4e79", "#3f3f3f", "#c46a1a"),
c(label_deti, label_pldd, label_ratio)
)
# =========================
# 8) Graf - verze pro prezentaci
# =========================
p <- ggplot(plot_df, aes(x = Rok, y = index, color = rada)) +
geom_hline(
yintercept = 100,
linewidth = 0.8,
linetype = "22",
color = "grey55"
) +
geom_line(
linewidth = 2.2,
lineend = "round",
na.rm = TRUE
) +
geom_point(
data = last_points,
size = 3.8,
stroke = 0.6,
fill = "white",
shape = 21,
na.rm = TRUE
) +
geom_label_repel(
data = last_points,
aes(label = label),
size = 4.3,
fontface = "bold",
fill = "white",
label.size = 0.25,
label.r = unit(0.18, "lines"),
direction = "y",
hjust = 0,
nudge_x = 0.8,
min.segment.length = 0,
box.padding = 0.35,
point.padding = 0.2,
segment.color = "grey50",
seed = 123,
show.legend = FALSE
) +
annotate(
"label",
x = base_year + 0.8,
y = 101.2,
label = paste0(base_year, " = 100"),
size = 4.0,
fill = "white",
label.size = 0.25,
color = "grey20",
fontface = "bold"
) +
scale_color_manual(values = color_values) +
scale_x_continuous(
breaks = seq(1994, 2024, by = 4),
limits = c(1993, 2024.8),
expand = expansion(mult = c(0.003, 0.003))
) +
scale_y_continuous(
labels = label_number(accuracy = 1, decimal.mark = ","),
expand = expansion(mult = c(0.05, 0.14))
) +
labs(
title = "Obr. 1: Vývoj dětské populace, počtu PLDD a dětí na 1 PLDD v ČR",
subtitle = paste0("Indexové srovnání, ", base_year, " = 100; popisky ukazují skutečné hodnoty v roce ", last_year),
x = NULL,
y = paste0("Index (", base_year, " = 100)"),
caption = "Zdroj: vlastní zpracování na základě ČSÚ a ÚZIS ČR."
) +
coord_cartesian(clip = "off") +
theme_minimal(base_size = 20) +
theme(
plot.title = element_text(
face = "bold",
size = 22,
hjust = 0.5,
margin = margin(b = 8)
),
plot.subtitle = element_text(
size = 15,
hjust = 0.5,
margin = margin(b = 16)
),
axis.title.y = element_text(size = 17, face = "bold", margin = margin(r = 12)),
axis.text.x = element_text(size = 14, face = "bold"),
axis.text.y = element_text(size = 14, face = "bold"),
legend.position = "none",
panel.grid.minor = element_blank(),
panel.grid.major.x = element_blank(),
panel.grid.major.y = element_line(color = "#d9d9d9", linewidth = 0.55),
plot.caption = element_text(
size = 12,
face = "italic",
hjust = 1,
color = "grey25",
margin = margin(t = 14)
),
plot.caption.position = "plot",
plot.margin = margin(18, 45, 30, 18)
)
print(p)
# =========================
# 9) Uložení grafu
# =========================
png_file <- file.path(out_dir, "slide_graf_3_linky_index_1993_2024_prezentace.png")
pdf_file <- file.path(out_dir, "slide_graf_3_linky_index_1993_2024_prezentace.pdf")
ggsave(
filename = png_file,
plot = p,
width = 13.333,
height = 7.5,
dpi = 320,
bg = "white"
)
ggsave(
filename = pdf_file,
plot = p,
width = 13.333,
height = 7.5,
device = cairo_pdf,
bg = "white"
)
# =========================
# 10) Datová tabulka
# =========================
export_df <- slide_df %>%
transmute(
Rok,
osoby_0_18 = round(osoby_0_18, 0),
pldd_fte_puvodni = round(Pediatri_FTE_rocenky, 1),
pldd_fte_dopocteno = round(pldd_fte_dopocteno, 1),
pldd_fte_ma = round(pldd_fte_ma, 1),
deti_na_1_pldd = round(deti_na_pldd, 1),
index_deti = round(index_deti, 1),
index_pldd = round(index_pldd, 1),
index_deti_na_pldd = round(index_deti_na_pldd, 1)
)
csv_file <- file.path(out_dir, "slide_data_3_linky_1993_2024_prezentace.csv")
xlsx_file <- file.path(out_dir, "slide_data_3_linky_1993_2024_prezentace.xlsx")
write.csv(export_df, csv_file, row.names = FALSE, fileEncoding = "UTF-8")
wb <- createWorkbook()
addWorksheet(wb, "data")
writeData(wb, "data", export_df)
saveWorkbook(wb, xlsx_file, overwrite = TRUE)
# =========================
# 11) Poznámky ke slidu
# =========================
value_base_deti <- slide_df %>%
filter(Rok == base_year) %>%
pull(osoby_0_18) %>%
safe_pull_one("děti v bázi")
value_last_deti <- slide_df %>%
filter(Rok == 2024) %>%
pull(osoby_0_18) %>%
safe_pull_one("děti 2024")
value_base_pldd <- slide_df %>%
filter(Rok == base_year) %>%
pull(pldd_fte_ma) %>%
safe_pull_one("PLDD v bázi")
value_last_pldd <- slide_df %>%
filter(Rok == 2024) %>%
pull(pldd_fte_ma) %>%
safe_pull_one("PLDD 2024")
value_base_ratio <- slide_df %>%
filter(Rok == base_year) %>%
pull(deti_na_pldd) %>%
safe_pull_one("děti/PLDD v bázi")
value_last_ratio <- slide_df %>%
filter(Rok == 2024) %>%
pull(deti_na_pldd) %>%
safe_pull_one("děti/PLDD 2024")
text_lines <- c(
"NÁVRH TEXTU NA SLIDE",
"--------------------",
"• Dětská populace v novějších letech zůstává relativně vysoká.",
"• Počet PLDD při použití klouzavého průměru spíše stagnuje až mírně klesá.",
"• Počet dětí na 1 PLDD proto roste a ukazuje zesilující tlak na kapacitu péče.",
"",
paste0("Báze indexu: ", base_year, " = 100"),
paste0("Děti 0–18: ", fmt_int(value_base_deti), " → ", fmt_int(value_last_deti)),
paste0("PLDD (", ma_window, "letý MA): ", fmt_dec(value_base_pldd, 0.1), " → ", fmt_dec(value_last_pldd, 0.1)),
paste0("Děti na 1 PLDD: ", fmt_dec(value_base_ratio, 0.1), " → ", fmt_dec(value_last_ratio, 0.1))
)
txt_file <- file.path(out_dir, "slide_poznamky_3_linky_prezentace.txt")
writeLines(text_lines, txt_file, useBytes = TRUE)
cat("\nHotovo.\n")
cat("PNG:  ", png_file, "\n", sep = "")
cat("PDF:  ", pdf_file, "\n", sep = "")
cat("CSV:  ", csv_file, "\n", sep = "")
cat("XLSX: ", xlsx_file, "\n", sep = "")
cat("TXT:  ", txt_file, "\n", sep = "")
