group_by(orp_key, orp_clean, pohlavi_key, vek_clean) %>%
summarise(
osoby = sum(hodnota_num, na.rm = TRUE),
.groups = "drop"
) %>%
arrange(orp_clean, pohlavi_key, suppressWarnings(as.integer(vek_clean)))
pop_orp_age <- pop_orp_age_sex %>%
group_by(orp_key, orp_clean, vek_clean) %>%
summarise(
osoby = sum(osoby, na.rm = TRUE),
.groups = "drop"
)
pop_orp_total <- pop_orp_age %>%
group_by(orp_key) %>%
summarise(
orp_clean = first_nonempty(orp_clean),
deti_0_18_2024 = sum(osoby, na.rm = TRUE),
.groups = "drop"
) %>%
arrange(desc(deti_0_18_2024), orp_clean)
pop_orp_groups <- pop_orp_age %>%
mutate(vekova_skupina = assign_age_group_col(vek_clean)) %>%
filter(!is.na(vekova_skupina)) %>%
group_by(orp_key, orp_clean, vekova_skupina) %>%
summarise(
osoby = sum(osoby, na.rm = TRUE),
.groups = "drop"
) %>%
select(-orp_clean) %>%
pivot_wider(
names_from = vekova_skupina,
values_from = osoby,
values_fill = 0
)
for (nm in c("g_0_2024", "g_1_4_2024", "g_5_9_2024", "g_10_14_2024", "g_15_18_2024")) {
if (!nm %in% names(pop_orp_groups)) pop_orp_groups[[nm]] <- 0
}
pop_orp_groups <- pop_orp_groups %>%
select(
orp_key,
g_0_2024, g_1_4_2024, g_5_9_2024, g_10_14_2024, g_15_18_2024
)
# =========================
# 6) Tvrdá kontrola základních hodnot
# =========================
kontrola_expected <- tibble::tribble(
~orp,               ~deti_expected, ~ordinace_expected, ~ukazatel_expected,
"Černošice",         40964,          1,                  40964,
"Šlapanice",         17483,          2,                  17483 / 2,
"Lysá nad Labem",     7927,          3,                  7927 / 3,
"Ústí nad Labem",    23928,         14,                  23928 / 14,
"Broumov",            2910,          2,                  2910 / 2,
"Děčín",             14509,         10,                  14509 / 10
)
kontrola_base <- pop_orp_total %>%
inner_join(ord_orp, by = "orp_key", suffix = c("_pop", "_ord")) %>%
mutate(
orp = coalesce(orp_clean_pop, orp_clean_ord),
demograficka_zatez = deti_0_18_2024 / pocet_ordinaci
) %>%
filter(orp %in% kontrola_expected$orp) %>%
select(orp, deti_0_18_2024, pocet_ordinaci, demograficka_zatez) %>%
left_join(kontrola_expected, by = "orp") %>%
mutate(
deti_ok = deti_0_18_2024 == deti_expected,
ordinace_ok = pocet_ordinaci == ordinace_expected,
ukazatel_ok = abs(demograficka_zatez - ukazatel_expected) < 1e-8
) %>%
arrange(match(orp, kontrola_expected$orp))
if (nrow(kontrola_base) != nrow(kontrola_expected) ||
!all(kontrola_base$deti_ok) ||
!all(kontrola_base$ordinace_ok) ||
!all(kontrola_base$ukazatel_ok)) {
print(kontrola_base, n = Inf)
stop("Kontrolní hodnoty ORP NESOUHLASÍ. Nejprve oprav základní vstupy.")
}
# =========================
# 7) A041 – NATVRDO list regiony 24
# =========================
reg_files <- list.files(reg_dir, pattern = "\\.xlsx$", full.names = TRUE)
if (length(reg_files) == 0) {
stop("Ve složce registrace není žádný XLSX soubor.")
}
reg_file <- reg_files[1]
preferred_idx <- which(
str_detect(
norm_text(basename(reg_files)),
"a041|prakticky lekar pro deti a dorost|vykaz a041|vykaz-a041"
)
)
if (length(preferred_idx) > 0) reg_file <- reg_files[preferred_idx[1]]
reg_sheets <- excel_sheets(reg_file)
if (!"regiony 24" %in% reg_sheets) {
cat("\nDostupné listy v A041:\n")
print(reg_sheets)
stop("V A041 chybí list 'regiony 24'.")
}
reg_sheet <- "regiony 24"
reg_raw <- read_excel(
reg_file,
sheet = reg_sheet,
col_names = FALSE,
.name_repair = "minimal"
)
if (nrow(reg_raw) == 0 || ncol(reg_raw) == 0) {
stop("List 'regiony 24' se nepodařilo načíst.")
}
labels_key <- label_key(reg_raw[[1]])
target_total_contacts <- "pocet kontaktu osetreni vysetreni s pacientem celkem"
target_prev_total     <- "pocet kontaktu osetreni vysetreni s pacientem preventivni celkem"
target_prev_0         <- "pocet kontaktu osetreni vysetreni s pacientem preventivni 0 11 mes"
target_prev_1_4       <- "pocet kontaktu osetreni vysetreni s pacientem preventivni 1 4 roky"
target_prev_5_9       <- "pocet kontaktu osetreni vysetreni s pacientem preventivni 5 9 let"
target_prev_10_14     <- "pocet kontaktu osetreni vysetreni s pacientem preventivni 10 14 let"
target_prev_15p       <- "pocet kontaktu osetreni vysetreni s pacientem preventivni 15 let a vice"
target_reg_0          <- "pocet registrovanych pacientu 0 11 mes"
target_reg_1_4        <- "pocet registrovanych pacientu 1 4 roky"
target_reg_5_9        <- "pocet registrovanych pacientu 5 9 let"
target_reg_10_14      <- "pocet registrovanych pacientu 10 14 let"
target_reg_15p        <- "pocet registrovanych pacientu 15 let a vice"
reg_2024 <- tibble(
vekova_skupina = c("0", "1-4", "5-9", "10-14", "15-18"),
registrovani_2024 = c(
find_row_exact_sum(reg_raw, labels_key, target_reg_0),
find_row_exact_sum(reg_raw, labels_key, target_reg_1_4),
find_row_exact_sum(reg_raw, labels_key, target_reg_5_9),
find_row_exact_sum(reg_raw, labels_key, target_reg_10_14),
find_row_exact_sum(reg_raw, labels_key, target_reg_15p)
)
)
prev_2024 <- tibble(
vekova_skupina = c("0", "1-4", "5-9", "10-14", "15-18"),
preventivni_kontakty_2024 = c(
find_row_exact_sum(reg_raw, labels_key, target_prev_0),
find_row_exact_sum(reg_raw, labels_key, target_prev_1_4),
find_row_exact_sum(reg_raw, labels_key, target_prev_5_9),
find_row_exact_sum(reg_raw, labels_key, target_prev_10_14),
find_row_exact_sum(reg_raw, labels_key, target_prev_15p)
)
)
celkove_kontakty_2024 <- find_row_exact_sum(reg_raw, labels_key, target_total_contacts)
preventivni_kontakty_celkem_2024 <- find_row_exact_sum(reg_raw, labels_key, target_prev_total)
if (any(is.na(reg_2024$registrovani_2024)) ||
any(is.na(prev_2024$preventivni_kontakty_2024)) ||
is.na(celkove_kontakty_2024) ||
is.na(preventivni_kontakty_celkem_2024)) {
cat("\nNepodařilo se najít některé řádky v listu 'regiony 24'.\n")
cat("\nŘádky obsahující 'registrovanych':\n")
print(reg_raw[grepl("registrovanych", labels_key), 1, drop = FALSE])
cat("\nŘádky obsahující 'preventivni':\n")
print(reg_raw[grepl("preventivni", labels_key), 1, drop = FALSE])
stop("A041: nepodařilo se najít požadované řádky v listu 'regiony 24'.")
}
ratio_total_prev <- celkove_kontakty_2024 / preventivni_kontakty_celkem_2024
# =========================
# 8) Národní věkové sazby a váhy 2024
# =========================
pop_nat_groups <- pop_prepared %>%
mutate(vekova_skupina = assign_age_group_col(vek_clean)) %>%
filter(!is.na(vekova_skupina)) %>%
mutate(
vekova_skupina = case_when(
vekova_skupina == "g_0_2024" ~ "0",
vekova_skupina == "g_1_4_2024" ~ "1-4",
vekova_skupina == "g_5_9_2024" ~ "5-9",
vekova_skupina == "g_10_14_2024" ~ "10-14",
vekova_skupina == "g_15_18_2024" ~ "15-18",
TRUE ~ NA_character_
)
) %>%
group_by(vekova_skupina) %>%
summarise(
population_2024 = sum(hodnota_num, na.rm = TRUE),
.groups = "drop"
)
age_rates_2024 <- pop_nat_groups %>%
left_join(reg_2024, by = "vekova_skupina") %>%
left_join(prev_2024, by = "vekova_skupina") %>%
mutate(
reg_rate = registrovani_2024 / population_2024,
prev_per_reg = preventivni_kontakty_2024 / registrovani_2024,
total_contacts_per_reg = prev_per_reg * ratio_total_prev,
age_suffix = c("0", "1_4", "5_9", "10_14", "15_18")
)
if (any(is.na(age_rates_2024$reg_rate)) ||
any(is.na(age_rates_2024$total_contacts_per_reg))) {
print(age_rates_2024, n = Inf)
stop("Nepodařilo se spočítat věkové sazby 2024.")
}
min_intensity <- min(age_rates_2024$total_contacts_per_reg, na.rm = TRUE)
age_rates_2024 <- age_rates_2024 %>%
mutate(
weight_age = total_contacts_per_reg / min_intensity
)
reg_rate_vec <- setNames(age_rates_2024$reg_rate, age_rates_2024$age_suffix)
contacts_vec <- setNames(age_rates_2024$total_contacts_per_reg, age_rates_2024$age_suffix)
weight_vec   <- setNames(age_rates_2024$weight_age, age_rates_2024$age_suffix)
# =========================
# 9) Finální analýza – index rizikovosti ORP
# =========================
analysis_orp <- pop_orp_total %>%
left_join(pop_orp_groups, by = "orp_key") %>%
inner_join(ord_orp, by = "orp_key", suffix = c("_pop", "_ord")) %>%
mutate(
orp = coalesce(orp_clean_pop, orp_clean_ord),
kraj = kraj_clean,
demograficka_zatez = deti_0_18_2024 / pocet_ordinaci,
reg_0     = g_0_2024     * reg_rate_vec[["0"]],
reg_1_4   = g_1_4_2024   * reg_rate_vec[["1_4"]],
reg_5_9   = g_5_9_2024   * reg_rate_vec[["5_9"]],
reg_10_14 = g_10_14_2024 * reg_rate_vec[["10_14"]],
reg_15_18 = g_15_18_2024 * reg_rate_vec[["15_18"]],
registrovani_odhad_2024 = reg_0 + reg_1_4 + reg_5_9 + reg_10_14 + reg_15_18,
visits_0     = reg_0     * contacts_vec[["0"]],
visits_1_4   = reg_1_4   * contacts_vec[["1_4"]],
visits_5_9   = reg_5_9   * contacts_vec[["5_9"]],
visits_10_14 = reg_10_14 * contacts_vec[["10_14"]],
visits_15_18 = reg_15_18 * contacts_vec[["15_18"]],
navstevy_odhad_2024 = visits_0 + visits_1_4 + visits_5_9 + visits_10_14 + visits_15_18,
vazena_populace_2024 =
g_0_2024     * weight_vec[["0"]] +
g_1_4_2024   * weight_vec[["1_4"]] +
g_5_9_2024   * weight_vec[["5_9"]] +
g_10_14_2024 * weight_vec[["10_14"]] +
g_15_18_2024 * weight_vec[["15_18"]],
vazena_demograficka_zatez = vazena_populace_2024 / pocet_ordinaci,
registracni_zatez = registrovani_odhad_2024 / pocet_ordinaci,
vykonova_zatez = navstevy_odhad_2024 / pocet_ordinaci
) %>%
transmute(
kraj = kraj,
orp = orp,
orp_key = orp_key,
deti_0_18_2024 = deti_0_18_2024,
pocet_ordinaci = pocet_ordinaci,
g_0_2024 = g_0_2024,
g_1_4_2024 = g_1_4_2024,
g_5_9_2024 = g_5_9_2024,
g_10_14_2024 = g_10_14_2024,
g_15_18_2024 = g_15_18_2024,
registrovani_odhad_2024 = registrovani_odhad_2024,
navstevy_odhad_2024 = navstevy_odhad_2024,
vazena_populace_2024 = vazena_populace_2024,
demograficka_zatez = demograficka_zatez,
vazena_demograficka_zatez = vazena_demograficka_zatez,
registracni_zatez = registracni_zatez,
vykonova_zatez = vykonova_zatez
) %>%
distinct(orp_key, .keep_all = TRUE) %>%
mutate(
z_demograficka = z_std(demograficka_zatez),
z_vazena = z_std(vazena_demograficka_zatez),
z_registracni = z_std(registracni_zatez),
z_vykonova = z_std(vykonova_zatez),
index_z_orp = rowMeans(
cbind(z_demograficka, z_vazena, z_registracni, z_vykonova),
na.rm = TRUE
)
) %>%
arrange(desc(index_z_orp), desc(vykonova_zatez), desc(registracni_zatez), desc(demograficka_zatez), orp)
if (nrow(analysis_orp) == 0) {
stop("Po spojení dat nezůstal žádný záznam.")
}
dup_check <- analysis_orp %>%
count(orp_key) %>%
filter(n > 1)
if (nrow(dup_check) > 0) {
print(dup_check)
stop("Po finálním joinu zůstaly duplicitní ORP.")
}
# =========================
# 10) TOP 10 nejhorších ORP
# =========================
top_n <- min(10, nrow(analysis_orp))
top10 <- analysis_orp %>%
slice_head(n = top_n) %>%
mutate(
poradi = row_number()
)
# =========================
# 11) Matice – 4 zátěže + index
# =========================
matice_df <- top10 %>%
select(
orp,
`Demografická zátěž` = demograficka_zatez,
`Vážená zátěž` = vazena_demograficka_zatez,
`Registrační zátěž` = registracni_zatez,
`Výkonová zátěž` = vykonova_zatez,
`Index Z-score ORP` = index_z_orp
) %>%
mutate(
orp = factor(orp, levels = rev(orp))
) %>%
pivot_longer(
cols = -orp,
names_to = "ukazatel",
values_to = "hodnota"
) %>%
group_by(ukazatel) %>%
mutate(
fill_value = z_std(hodnota),
label = case_when(
ukazatel == "Index Z-score ORP" ~ fmt_dec2(hodnota),
TRUE ~ fmt_dec1(hodnota)
)
) %>%
ungroup() %>%
mutate(
ukazatel = factor(
ukazatel,
levels = c(
"Demografická zátěž",
"Vážená zátěž",
"Registrační zátěž",
"Výkonová zátěž",
"Index Z-score ORP"
)
)
)
plot_matice <- ggplot(matice_df, aes(x = ukazatel, y = orp, fill = fill_value)) +
geom_tile(color = "white", linewidth = 1) +
geom_text(aes(label = label), size = 4.0) +
scale_fill_gradient2(
low = "#d9e8f5",
mid = "#6fa0c9",
high = "#1f5e98",
midpoint = 0,
guide = "none"
) +
scale_x_discrete(position = "top") +
labs(
title = "Index zatížení a „rizikovost“ ORP v roce 2024",
subtitle = "TOP 10 nejhorších ORP podle souhrnného Z-score indexu",
x = NULL,
y = NULL
) +
theme_minimal(base_size = 13) +
theme(
panel.grid = element_blank(),
axis.text.x = element_blank(),
axis.ticks.x = element_blank(),
axis.text.x.top = element_text(face = "bold", size = 11),
axis.ticks.x.top = element_blank(),
axis.text.y = element_text(size = 12),
plot.title = element_text(face = "bold", size = 20),
plot.subtitle = element_text(size = 11)
)
# =========================
# 12) Tabulka TOP 10 pod matici
# =========================
tabulka_top10 <- top10 %>%
transmute(
`Pořadí` = poradi,
`ORP` = orp,
`Index Z-score ORP` = fmt_dec2(index_z_orp)
)
table_theme <- ttheme_minimal(
base_size = 11,
core = list(fg_params = list(hjust = 0, x = 0.02)),
colhead = list(fg_params = list(fontface = "bold"))
)
table_grob <- tableGrob(
tabulka_top10,
rows = NULL,
theme = table_theme
)
combined_grob <- arrangeGrob(
plot_matice,
table_grob,
ncol = 1,
heights = c(3.15, 1.1)
)
png(
filename = file.path(output_dir, "6.4.3_index_rizikovosti_orp_matice_a_top10.png"),
width = 5000,
height = 3600,
res = 300,
bg = "white"
)
grid.newpage()
grid.draw(combined_grob)
dev.off()
ggsave(
filename = file.path(output_dir, "6.4.3_index_rizikovosti_orp_matice.png"),
plot = plot_matice,
width = 14.8,
height = 8.8,
dpi = 300,
bg = "white"
)
# =========================
# 13) Diagnostika
# =========================
ord_unmatched <- ord_orp %>%
anti_join(pop_orp_total, by = "orp_key") %>%
arrange(kraj_clean, orp_clean)
pop_without_ordinance <- pop_orp_total %>%
anti_join(ord_orp, by = "orp_key") %>%
arrange(desc(deti_0_18_2024), orp_clean)
summary_stats <- tibble(
ukazatel = c(
"ORP v populačních datech",
"ORP s ordinací v NR-01-06",
"ORP v průniku",
"Celkový počet ordinací v analyzovaných ORP",
"TOP N v matici"
),
hodnota = c(
nrow(pop_orp_total),
nrow(ord_orp),
nrow(analysis_orp),
sum(analysis_orp$pocet_ordinaci, na.rm = TRUE),
top_n
)
)
# =========================
# 14) Uložení dat
# =========================
write_csv(age_rates_2024, file.path(output_dir, "6.4.3_a041_vekove_sazby_2024.csv"))
write_csv(pop_orp_age_sex, file.path(output_dir, "6.4.3_orp_populace_detail_vek_pohlavi_2024.csv"))
write_csv(pop_orp_age, file.path(output_dir, "6.4.3_orp_populace_detail_vek_2024.csv"))
write_csv(pop_orp_groups, file.path(output_dir, "6.4.3_orp_populace_skupiny_2024.csv"))
write_csv(pop_orp_total, file.path(output_dir, "6.4.3_orp_populace_2024.csv"))
write_csv(ord_base, file.path(output_dir, "6.4.3_ordinace_vstup_vsechny_radky.csv"))
write_csv(ord_orp, file.path(output_dir, "6.4.3_ordinace_2024.csv"))
write_csv(analysis_orp, file.path(output_dir, "6.4.3_index_rizikovosti_orp_2024.csv"))
write_csv(top10, file.path(output_dir, "6.4.3_top10_nejhorsich_orp_2024.csv"))
write_csv(tabulka_top10, file.path(output_dir, "6.4.3_top10_tabulka.csv"))
write_csv(kontrola_base, file.path(output_dir, "6.4.3_kontrola_zakladnich_hodnot.csv"))
write_csv(summary_stats, file.path(output_dir, "6.4.3_souhrnne_pocty.csv"))
write_csv(ord_unmatched, file.path(output_dir, "6.4.3_ordinace_bez_napojeni_na_populaci.csv"))
write_csv(pop_without_ordinance, file.path(output_dir, "6.4.3_orp_bez_ordinace.csv"))
# =========================
# 15) Excel
# =========================
wb <- createWorkbook()
addWorksheet(wb, "index_rizikovosti_orp")
writeData(wb, "index_rizikovosti_orp", analysis_orp)
addWorksheet(wb, "top10")
writeData(wb, "top10", top10)
addWorksheet(wb, "top10_tabulka")
writeData(wb, "top10_tabulka", tabulka_top10)
addWorksheet(wb, "vekove_sazby")
writeData(wb, "vekove_sazby", age_rates_2024)
addWorksheet(wb, "populace_skupiny")
writeData(wb, "populace_skupiny", pop_orp_groups)
addWorksheet(wb, "populace_2024")
writeData(wb, "populace_2024", pop_orp_total)
addWorksheet(wb, "ordinace_2024")
writeData(wb, "ordinace_2024", ord_orp)
addWorksheet(wb, "kontrola")
writeData(wb, "kontrola", kontrola_base)
addWorksheet(wb, "souhrn")
writeData(wb, "souhrn", summary_stats)
saveWorkbook(
wb,
file = file.path(output_dir, "6.4.3_index_rizikovosti_orp_2024.xlsx"),
overwrite = TRUE
)
# =========================
# 16) Textový souhrn
# =========================
writeLines(
c(
"6.4.3 – Index zatížení a „rizikovost“ regionu (ORP)",
"",
"Použitá logika:",
"- demografická zátěž = děti 0–18 / ordinace",
"- vážená zátěž = vážená dětská populace / ordinace",
"- registrační zátěž = aproximace registrovaných / ordinace",
"- výkonová zátěž = aproximace návštěv / ordinace",
"- index Z-score ORP = průměr z-score všech čtyř ukazatelů",
"",
paste0("Počet analyzovaných ORP: ", nrow(analysis_orp)),
paste0("TOP 10 nejhorších ORP bylo zobrazeno v matici.")
),
con = file.path(output_dir, "6.4.3_metodika_index_rizikovosti.txt")
)
# =========================
# 17) Konzole
# =========================
cat("\n=====================================================\n")
cat("ANALÝZA HOTOVO\n")
cat("Výstupní složka:", output_dir, "\n")
cat("Použitý list A041:", reg_sheet, "\n")
cat("=====================================================\n\n")
cat("Souhrnné počty:\n")
print(summary_stats, n = Inf)
cat("\nPoužité národní sazby a váhy:\n")
print(age_rates_2024, n = Inf)
cat("\nKontrola základních hodnot:\n")
print(kontrola_base, n = Inf)
cat("\nTOP 10 nejhorších ORP:\n")
print(
top10 %>%
select(
orp,
demograficka_zatez,
vazena_demograficka_zatez,
registracni_zatez,
vykonova_zatez,
index_z_orp
),
n = Inf
)
cat("\nVytvořené soubory:\n")
cat("- 6.4.3_index_rizikovosti_orp_matice.png\n")
cat("- 6.4.3_index_rizikovosti_orp_matice_a_top10.png\n")
cat("- 6.4.3_index_rizikovosti_orp_2024.csv\n")
cat("- 6.4.3_index_rizikovosti_orp_2024.xlsx\n")
cat("- 6.4.3_metodika_index_rizikovosti.txt\n")
