Modelování výše grantů Evropského sboru solidarity

Autor

Romana Pejcalová

Publikováno

12. března 2023

Zobrazit kód

# Načtení používaných balíčků
library(tidyverse)
library(kableExtra)
library(plotly)
library(scales)
library(modelsummary)
library(ggplot2)

# Načetní datasetu
load("solidarita.RData")

# Funkce na přejmenování sloupců: . -> _
rename_cols <- function(df) {
  names(df) <- gsub("\\.", "_", names(df))
  df
}
solidarita       <- rename_cols(solidarita)

# Příprava proměnných
solidarita <- solidarita |>
  mutate(
    activities_more_than_one = activities_count > 1,
    length_months = ceiling(as.integer(length_days) / 30),
    action_2 = factor(
      ifelse(action %in% c("Volunteering Projects", 
                           "Volunteering Teams in High Priority Areas"),
             "Volunteering", "Other"),
      levels = c("Other", "Volunteering")
    ),
    eu_subregions_2 = factor(
      ifelse(eu_subregions == "Eastern Europe", "Eastern", "Other"),
      levels = c("Other", "Eastern")
    )
  )

# Data pro modelování (bez NA a nul)
solidarita_model <- solidarita |>
  filter(!is.na(eu_grant), eu_grant > 0, 
         !is.na(eu_subregions_2))

1 Evropský sbor solidarity

Evropský sbor solidarity je iniciativa Evropské komise zaměřená na podporu mladých lidí ve věku 18–30 let, kteří se chtějí aktivně zapojit do veřejně prospěšných projektů – ať už ve své domovské zemi, nebo v zahraničí. Hlavním cílem je podpora dobrovolnictví, stáží a pracovních příležitostí v oblasti solidární pomoci, občanské angažovanosti a inkluzivní společnosti.

Program nabízí čtyři typy aktivit:

Dobrovolnické projekty (Volunteering Projects) – nejčastější forma, projekty zaměřené na pomoc potřebným.
Projekty solidarity (Solidarity Projects) – menší místní projekty iniciované samotnými mladými lidmi.
Stáže a pracovní místa (Traineeships and Jobs) – pracovní a vzdělávací příležitosti se společenským přínosem.
Dobrovolnické týmy v oblastech s vysokou prioritou (Volunteering Teams in High Priority Areas) – mezinárodní dobrovolnické týmy zaměřené na aktuální priority Evropské unie.

Projekty jsou spolufinancovány z grantu EU a jejich výše závisí na řadě faktorů – délce projektu, typu aktivity, či tématickém zaměření.

2 Sběr a struktura dat

2.1 Získání dat

Data byla získána scrapováním veřejně dostupného portálu youth.europa.eu/solidarity/projects, který eviduje všechny schválené projekty. Ke každému projektu jsou dostupné informace o výši grantu, době realizace, tematickém zaměření, žadateli a zemi původu.

Datový soubor byl dále rozšířen o charakteristiky jednotlivých zemí, jako jsou subregion, státní zřízení, členství v EU, EMU, NATO a OSN, hustota zalidnění, HDP, míra nezaměstnanosti a Human Freedom Index.

2.2 Struktura datasetu

Tabulka 1: Základní popis datasetu

Charakteristika	Hodnota
Celkový počet pozorování	7 231
Počet zemí	34 (vč. Turecka; Curaçao a Aruba jako samostatné státy)
Výstupní proměnná	Výše grantu (v €)
Počet indikátorů	104+
Pozorování s vyplněným grantem (> 0)	7 168 (99,1 %)
Rok zahájení projektů	2019–2022
Dokončeno (ke dni analýzy)	přibližně 93,76 %

Indikátory lze rozdělit do tří skupin: (1) charakteristiky schválených projektů (datum realizace, témata, typ výzvy, počet aktivit), (2) charakteristiky žadatelské země (subregion, státní zřízení, členství v mezinárodních organizacích, ekonomické ukazatele, Human Freedom Index) a (3) tematické okruhy projektů (vzdělání, občanství, rovnost, kultura, ekologie, evropanství, životní styl, regionální, digitální).

2.3 Výše grantu jako cílová proměnná

Výše grantu je kladná spojitá proměnná s výrazně pravostranně asymetrickým rozdělením a četnými odlehlými hodnotami.

Obrázek 1: Histogram výše grantu (oříznutý na 200 tis. €)

Obrázek 2: Krabicový diagram výše grantu (bez oříznutí)

Tabulka 2: Číselné charakteristiky výše grantu

Ukazatel	Hodnota
Průměr	28 396 €
Medián	12 479 €
1. kvartil	6 888 €
3. kvartil	29 514 €
Směrodatná odchylka	56 436 €
IQR	22 626 €
Variační koeficient	198,7 %
Počet NA	63

Rozdělení výše grantu je výrazně pravostranně asymetrické. Většina projektů získala nižší granty, zatímco menší počet projektů obdržel velmi vysoké částky. Tomu odpovídá skutečnost, že průměr (28 396 €) je 2,28x vyšší než medián (12 479 €) a převyšuje jej pouze 27 % pozorování. Variační koeficient dosahuje 198,7 %, což ukazuje na značnou heterogenitu financovaných projektů. Polovina grantů se nachází v intervalu mezi prvním a třetím kvartilem (6 888 € až 29 514 €). Lillieforsův test normality zamítá na 5% hladině předpoklad normálního rozdělení (\(p\)-hodnota < 2,2 \(\times 10^{-16}\)).

Nenormalita závislé proměnné sama o sobě nepředstavuje problém pro regresní modelování. Vzhledem k charakteru dat (kladné hodnoty, asymetrie, odlehlá pozorování) však může být vhodnější využít GLM namísto klasické lineární regrese.

2.4 Průzkumová analýza dat

2.4.1 Výše grantů podle struktury projektů

Zobrazit kód

# Projekty s nenulovým grantem a kategorií délky
s_nz <- solidarita |>
  filter(!is.na(eu_grant), eu_grant > 0) |>
  mutate(delka_kat = 
           cut(as.integer(length_days),
               breaks = c(0, 365, 730, 1095, 1461),
               labels = c("méně než rok", "1–2 roky", "2–3 roky", "3–4 roky"),
               right = FALSE))

Typický projekt je dobrovolnický projekt s délkou realizace 1–2 roky a zaměřením na tři tematické okruhy.

Nadprůměrné granty jsou téměř výhradně spojeny s dobrovolnickými projekty (96 %), zatímco u podprůměrných grantů jsou podobně zastoupeny projekty typu Solidarity i Volunteering.

Významným faktorem je délka projektu. S rostoucí délkou realizace roste i výše grantu, což odpovídá vyšší finanční náročnosti dlouhodobých aktivit. U podprůměrných grantů je 85 % projektů kratších než dva roky, zatímco u nadprůměrných grantů trvá 85 % projektů jeden až tři roky.

2.4.2 Geopolitické charakteristiky žadatelů

Do analýzy bylo zahrnuto 34 států. Vedle členských zemí EU jsou samostatně evidována také některá zámořská území, například Curaçao a Aruba.

Nejčastějšími žadateli jsou Španělsko (10,5 %), Itálie (9 %), Německo (8,7 %) a Francie (7,3 %) – tato čtveřice tvoří dohromady 35 % všech projektů. Přestože podávají nejvíce žádostí, průměrná výše jejich grantů je nižší než celkový průměr.

Naopak Velká Británie dosahuje průměrné výše grantu až 3,5× vyšší než celkový průměr. Přestože britské organizace získaly pouze 1,6 % všech grantů, připadlo na ně 6,1 % celkového objemu přidělených finančních prostředků. Jedním z důvodů může být vyšší zastoupení dobrovolnických projektů, které jsou zpravidla finančně náročnější.

Zatímco Německo, Francie, Španělsko a Itálie realizovaly větší počet spíše menších projektů, Česká republika, Slovensko, Slovinsko, Švédsko, Řecko a Portugalsko získaly menší počet grantů s vyšší průměrnou finanční podporou.

Z regionálního pohledu dominovaly státy jižní Evropy (29 %) a střední Evropy (28 %), následované východní (17 %), západní (14 %) a severní Evropou (4 %). Celkově pocházelo 53 % projektů ze zemí bývalého východního bloku a 40 % ze západní Evropy.

Vyšší granty lze pozorovat především u projektů ze severní a západní Evropy a ze států s přístupem k moři, přičemž výsledky jsou ovlivněny několika mimořádně vysokými granty. Z pohledu státního zřízení jsou rozdíly ve výši grantů spíše malé, přesto monarchie vykazují mírně nižší hodnoty než republiky. Rozdíly mezi jednotlivými skupinami jsou však podstatně menší než variabilita grantů uvnitř těchto kategorií.

Vyšší granty jsou patrné také u států mimo eurozónu a u zemí s delší historií členství v OSN a NATO. Délka členství v EU, NATO a OSN, počet europoslanců, rozloha a populace spolu silně korelují. Tyto proměnné proto nesou podobnou informaci a při modelování je třeba počítat s multikolinearitou.

2.4.3 Tematické zaměření projektů

Obrázek 3: Zastoupení tematických okruhů v projektech

Nejčastěji se projekty věnují vzdělání (59 %), občanství (51 %) a rovnosti (49 %), přičemž jednotlivá témata jsou mezi typy výzev rozložena podobně. Výraznější odchylky lze pozorovat pouze u vzdělávání, evropanství a občanství. Kultura (27 %) a ekologie (18 %) jsou zastoupeny méně často, zatímco témata zdravého životního stylu, evropské identity, regionálního rozvoje a digitalizace se objevují spíše okrajově. Zároveň víme z Sekce 2.4.1, že typický projekt se zaměřuje na více tematických okruhů současně. Pravděpodobně tedy především na vzdělávání, občanskou participaci a rovnost.

3 Zdůvodnění volby zobecněného lineárního modelu

Výše grantu je kladná spojitá proměnná s výrazně pravostranně asymetrickým rozdělením a těžkým pravým chvostem. Klasický lineární regresní model (OLS) by byl nevhodný hned z několika důvodů:

Zobrazit kód

# Klasický lineární model (OLS)
model_ols <- 
  lm(eu_grant ~ action + length_months + nato_delka_clenstvi + length_years +
      osn_delka_clenstvi + activities_count + topics_count + 
       eu_subregions_eurovoc + f_statni_zrizeni + osn_clenem + 
       prumer4_populace + prumer4_hdp + prumer_hustota_osidleni + 
       topic_obcanstvi + topic_kultura +  topic_evropanstvi + 
       topic_regionalni, data = solidarita)

# Diagnostické grafy
par(mfrow = c(1, 4))
plot(model_ols)

Obrázek 4: Diagnostické grafy klasického lineárního modelu

Omezení klasického lineárního modelu

Především připouští záporné predikce, které u výše grantu nedávají smysl.
Dále předpokládá normální rozdělení reziduí, zatímco dle diagnpstických grafů jsou sice přibližně symetrická, ale výrazně špičatá a vykazují těžké chvosty.
Současně není splněn předpoklad konstantního rozptylu reziduí – jejich variabilita se zvyšuje s očekávanou hodnotou grantu.
V datech se navíc nachází několik vlivných pozorování s mimořádně vysokou výší grantu.

Klasický lineární model proto není pro modelování výše grantu vhodný a byla zvolena zobecněná lineární regrese s Gamma rozdělením a logaritmickou linkovací funkcí:

model <- glm(eu_grant ~ ., data = solidarita_model, family = Gamma(link = "log"))

Gamma GLM s logaritmickou linkovací funkcí

Gamma rozdělení je vhodnou volbou pro modelování kladných spojitých proměnných, u nichž rozptyl roste s očekávanou střední hodnotou. Logaritmická linkovací funkce současně zajišťuje, že predikované hodnoty grantu jsou vždy kladné:

\[\log(\mathbb{E}[\text{grant}_i]) = \mathbf{x}_i^\top \boldsymbol{\beta}\]

Po exponenciaci získáme multiplikativní tvar modelu:

\[\mathbb{E}[\text{grant}_i] = e^{\mathbf{x}_i^\top \boldsymbol{\beta}}\]

Každý koeficient \(\beta_k\) se interpretuje tak, že při zvýšení příslušného prediktoru o jednu jednotku se očekávaná výše grantu změní \(e^{\beta_k}\)-krát za jinak stejných podmínek. Log-lineární model tak zachycuje relativní (procentní) změny, které bývají při ekonomické interpretaci přirozenější než změny absolutní.

4 Porovnání modelů s interakcemi a bez interakcí

4.1 Použité proměnné a přístup

Ze všech dostupných indikátorů bylo po průzkumové analýze vybráno šest vysvětlujících proměnných:

Tabulka 3: Vysvětlující proměnné ve finálních modelech

Proměnná	Typ	Popis
`activities_more_than_one`	Binární	Zda má projekt více než jednu aktivitu
`length_days`	Spojitá	Délka projektu ve dnech
`action_2`	Faktor (2 úrovně)	Typ výzvy: Dobrovolnictví / Solidarita + Stáže a pracovní místa
`eu_subregions_2`	Faktor (2 úrovně)	Subregion žadatele: Západní Evropa + Severní Afrika + Blízký východ / Východní Evropa
`sea`	Binární	Zda má žadatelská země přístup k moři
`topic_rovnost`	Binární	Zda se projekt týká rovnosti (rovné příležitosti, inkluze apod.) / jiného téma než rovnost

Modelování probíhalo ve dvou krocích: nejprve byl vybrán model bez interakcí (postupným odebíráním nevýznamných koeficientů), poté byl doplněn o interakce 1. řádu a opět redukován.

Zobrazit kód

# Převod délky projektu na celé měsíce
solidarita_model$length_months <- ceiling(solidarita_model$length_days / 30)

# Model bez interakce
model_nointer_final <- glm(
  eu_grant ~ activities_more_than_one + length_months + action_2 +
    eu_subregions_2 + sea + topic_rovnost,
  data = solidarita_model, family = Gamma(link = "log")
)

# Model s vybranými interakcemi druhého řádu
model_inter_final <- glm(
  eu_grant ~
    topic_rovnost + 
    (activities_more_than_one + length_days + action_2 + eu_subregions_2 + sea)^2 -
    activities_more_than_one:length_days -
    activities_more_than_one:action_2 -
    activities_more_than_one:sea -
    length_days:eu_subregions_2,
  data = solidarita_model, family = Gamma(link = "log")
)

4.2 Kvantitativní srovnání kvality modelů

Zobrazit kód

# Pomocné souhrnné statistiky modelů pro použití v textu
aic_ni <- round(AIC(model_nointer_final), 1)
bic_ni <- round(BIC(model_nointer_final), 1)
aic_i  <- round(AIC(model_inter_final), 1)
bic_i  <- round(BIC(model_inter_final), 1)
dev_ni <- round(1 - model_nointer_final$deviance / model_nointer_final$null.deviance, 4)
dev_i  <- round(1 - model_inter_final$deviance  / model_inter_final$null.deviance,  4)
p_anova <- anova(model_nointer_final, 
                 model_inter_final, test = "LRT")[["Pr(>Chi)"]][2]

# Modelsummary nezahrnuje pseudo-R2 ani LRT X2 - přidáme je jako vlastní GOF statistiky
glance_custom.glm <- function(x, ...) {
  data.frame(
    pseudo_r2 = scales::percent(
      1 - (x$deviance / x$null.deviance),
      accuracy = 0.1, decimal.mark = ","
    ),
    lrt_x2    = x$null.deviance - x$deviance,
    lrt_df = as.integer(x$df.null - x$df.residual),
    n_params = as.integer(x$df.null - x$df.residual + 1)
  )
}

# Definice statistik zobrazovaných ve spodní části tabulky
gof_custom <- tribble(
  ~raw,        ~clean,              ~fmt,
  "nobs",      "Počet pozorování",  0,
  "n_params",  "Počet parametrů",   0,
  "aic",       "Akaikeho informační kritérium (AIC)",               1,
  "bic",       "Bayesovo informační kritérium (BIC)",               1,
  "pseudo_r2", "Pseudo-R²",         3,
  "lrt_x2",     "LRT X2 statistika",          2,
  "df.residual", "Residuální stupně volnosti",  0
)

# Vytvoření tabulky koeficientů a statistik modelů
df <- modelsummary(
  list(
    "Model bez interakce" = model_nointer_final,
    "Model s interakcí"   = model_inter_final
  ),
  estimate   = "{estimate} [{conf.low}; {conf.high}] {stars}",
  statistic  = NULL,
  conf_level = 0.95,
  exponentiate = TRUE,
  fmt   = 2,
  stars = c("." = 0.1, "*" = 0.05, "**" = 0.01, "***" = 0.001),
  # gof_omit = "F|RMSE|R2|dev",
  gof_map  = gof_custom,
  coef_rename = c(
    "(Intercept)" = "(Konstanta)",
    "topic_rovnostTRUE" = "Téma rovnosti",
    "activities_more_than_oneTRUE" = "Více než jedna aktivita",
    "length_days" = "Délka projektu (dny)",
    "action_2Volunteering" = "Dobrovolnický projekt",
    "eu_subregions_2Eastern" = "Východní Evropa",
    "seaTRUE" = "Přímořská destinace",
    "activities_more_than_oneTRUE:eu_subregions_2Eastern" = "Více aktivit × Východní Evropa",
    "length_days:action_2Volunteering" = "Délka (dny) × Dobrovolnictví",
    "length_days:seaTRUE" = "Délka (dny) × Přímořská destinace",
    "action_2Volunteering:eu_subregions_2Eastern" = "Dobrovolnictví × Východní evropa",
    "action_2Volunteering:seaTRUE" = "Dobrovolnictví × Přímořská destinace",
    "eu_subregions_2Eastern:seaTRUE" = "Východní EU × Přímořská destinace",
    "length_months" = "Délka projektu (měsíce)"
    ),
  output   = "data.frame"
)


# cell_spec() obaluje hodnoty HTML tagy; parse_val je odstraní před numerickým porovnáním
parse_val <- function(x) {
  x |>
    gsub("<.*?>", "", x = _) |>   # odstraň případné HTML tagy
    gsub("%",     "", x = _) |>
    gsub("\u00a0", "", x = _) |>  # nezlomitelná mezera
    gsub("\\s+",  "", x = _) |>
    gsub(",",     ".", x = _) |>
    trimws() |>
    as.numeric()
}

# Řádky obsahující statistiky kvality modelu
gof_idx <- which(
  df$part == "gof" &
  grepl("AIC|BIC|R2|LRT", df$term)
)

# Zvýraznění lepší hodnoty zeleně a tučně
# (nižší AIC/BIC, vyšší pseudo-R2/LRT X2)
for (i in gof_idx) {
  val4 <- parse_val(df[[4]][i])
  val5 <- parse_val(df[[5]][i])

  lower_better <- grepl("AIC|BIC", df$term[i])

  better_col <- if (is.na(val4) || is.na(val5)) NA_integer_ else
    if (lower_better) {
      if (val4 <= val5) 4L else 5L
    } else {
      if (val4 >= val5) 4L else 5L
    }

  if (!is.na(better_col)) {
    df[[better_col]][i] <- cell_spec(
      df[[better_col]][i],
      bold  = TRUE,
      color = "#007B3DFF"
    )
  }
}

# První řádek sekce statistik modelu
first_gof_row <- which(df$part == "gof")[1]

# Vykreslení výsledné tabulky a oddělení sekce statistik modelu
df |> select(term, `Model bez interakce`, `Model s interakcí`) |>
  kbl(escape = FALSE,
      col.names = c("", "Model bez interakce", "Model s interakcí"),
      align = c("l", "c", "c")) |>
  kable_styling() |>
  pack_rows("Statistiky modelu", first_gof_row, nrow(df),
            bold = FALSE, italic = TRUE, color = "gray40")

Tabulka 4: Srovnání modelu bez interakce a s interakcí

	Model bez interakce	Model s interakcí
(Konstanta)	2930,02 [2694,41; 3187,86] ***	4311,19 [3494,81; 5335,07] ***
Více než jedna aktivita	7,06 [6,16; 8,14] ***	8,84 [7,50; 10,52] ***
Délka projektu (měsíce)	1,05 [1,04; 1,05] ***
Dobrovolnický projekt	3,15 [3,00; 3,30] ***	2,87 [2,39; 3,46] ***
Východní Evropa	1,13 [1,08; 1,18] ***	0,72 [0,62; 0,84] ***
Přímořská destinace	1,21 [1,14; 1,29] ***	0,73 [0,60; 0,89] ***
Téma rovnosti	1,06 [1,02; 1,11] **	1,06 [1,02; 1,10] **
Délka projektu (dny)		1,00 [1,00; 1,00] ***
Více aktivit × Východní Evropa		0,49 [0,38; 0,66] ***
Délka (dny) × Dobrovolnictví		1,00 [1,00; 1,00] ***
Délka (dny) × Přímořská destinace		1,00 [1,00; 1,00] *
Dobrovolnictví × Východní evropa		1,46 [1,33; 1,59] ***
Dobrovolnictví × Přímořská destinace		1,31 [1,14; 1,50] ***
Východní EU × Přímořská destinace		1,30 [1,12; 1,51] ***
Statistiky modelu
Počet pozorování	7167	7167
Počet parametrů	7	13
Akaikeho informační kritérium (AIC)	153379,0	153166,3
Bayesovo informační kritérium (BIC)	153434,0	153262,5
Pseudo-R2	63,1%	64,1%
LRT X2 statistika	5697,40	5793,38

Model s interakcemi dosahuje lepších hodnot všech sledovaných kritérií (AIC, BIC, pseudo-\(R^2\) i LRT \(\chi^2\)). Test poměru věrohodností ukázal, že přidání interakcí vede ke statisticky významnému zlepšení modelu (\(p\)-hodnota = 2,079712^{-28}). Za cenu lepšího fitu je však model interpretačně složitější.

4.3 Vizuální porovnání modelových predikcí

Grafy níže ukazují predikované křivky obou modelů pro dvě vybrané kombinace kovariát – scenáře s nejnižšími a nejvyššími hodnotami grantu.

Zobrazit kód

# Definice dvou typických profilů projektů pro porovnání predikcí
profil1 <- list(activities_more_than_one = FALSE, action_2 = "Other",
                eu_subregions_2 = "Other", sea = FALSE, topic_rovnost = FALSE)
profil2 <- list(activities_more_than_one = TRUE,  action_2 = "Volunteering",
                eu_subregions_2 = "Eastern",  sea = TRUE, topic_rovnost = TRUE)

# Funkce vytvoří predikce pro zvolený profil a oba modely
predikce <- function(profil, data, model_ni, model_i) {

  # Výběr pozorování odpovídajících danému profilu
  red <- data |> filter(
    activities_more_than_one == profil$activities_more_than_one,
    action_2        == profil$action_2,
    eu_subregions_2 == profil$eu_subregions_2,
    sea             == profil$sea,
    topic_rovnost   == profil$topic_rovnost
  )

  # Rozsah délky projektu použitý pro predikční křivku
  lseq <- seq(min(red$length_days, na.rm = TRUE),
              max(red$length_days, na.rm = TRUE))
  
  # Nová data pro predikci; délka v měsících je pouze aproximační
  nd <- tibble(!!!profil, length_days = lseq, length_months = lseq / 30) 
  # length_months = lseq / 30 -> aproximace misto ceiling(lseq / 30)

  # Predikce na linkové škále a převod zpět na původní škálu grantu
  pred_one <- function(model, label) {
    p <- predict(model, newdata = nd, type = "link", se.fit = TRUE)
    tibble(dny = lseq, model = label,
           fit = exp(p$fit),
           lo  = exp(p$fit - 1.96 * p$se.fit),
           hi  = exp(p$fit + 1.96 * p$se.fit))
  }
  list(df  = bind_rows(pred_one(model_ni, "Bez interakcí"),
                       pred_one(model_i,  "S interakcemi")),
       red = red)
}

# Funkce pro vykreslení predikčních křivek a intervalů spolehlivosti
plot_predikce <- function(res) {
  ggplot(res$df, aes(x = dny, y = fit, color = model, fill = model)) +
    geom_ribbon(aes(ymin = lo, ymax = hi), color = NA) +
    geom_line(linewidth = 1) +
    geom_point(data = res$red, aes(x = length_days, y = eu_grant),
               inherit.aes = FALSE, size = 0.8, color = "grey40") +
    scale_color_manual(values = 
                         c("Bez interakcí" = barvy[1], "S interakcemi" = barvy[5])) +
    scale_fill_manual(values  
                      = c("Bez interakcí" = barvy[1], "S interakcemi" = barvy[5])) +
    scale_y_continuous(labels = label_number(suffix = " tis.", scale = 1e-3)) +
    labs(x = "Délka projektu (dny)", y = "Výše grantu (€)",
         color = NULL, fill = NULL) +
    guides(fill = "none") +
    theme(legend.position = "top",
          plot.subtitle = element_text(size = 9, color = "gray40"))
}

# Výpočet predikcí pro oba profily
res1 <- predikce(profil1, solidarita_model, model_nointer_final, model_inter_final)
res2 <- predikce(profil2, solidarita_model, model_nointer_final, model_inter_final)

Interakce mění nejen velikost, ale i směr některých efektů. Zatímco u méně typických projektů vedou k vyšším odhadům grantů, u profilu odpovídajícího nejčastějším dobrovolnickým projektům ve východní Evropě vedou naopak k nižším predikovaným grantům, zejména u delších projektů.

5 Finální model výše grantu

Po zvážení obou modelů prezentujeme model bez interakcí jako primární výsledek – je interpretačně přímočarý, dosahuje srovnatelné vysvětlující síly (pseudo-\(R^2\) 63,05 %) a splňuje diagnostické podmínky.

5.1 Rovnice modelu

\[ \begin{aligned} \log(\widehat{\text{grant}}_i) &= 7{,}983 + 1{,}955 \cdot \mathbb{I}[\text{activities} > 1] + 0{,}044 \cdot \text{months}_i + 1{,}147 \cdot \mathbb{I}[\text{volunteering}]\\ &\quad + 0{,}117 \cdot \mathbb{I}[\text{Eastern}] + 0{,}193 \cdot \mathbb{I}[\text{sea}] + 0{,}062 \cdot \mathbb{I}[\text{rovnost}] \end{aligned} \]

V multiplikativní formě:

\[ \widehat{\text{grant}}_i = 2930 \times 7{,}06^{\mathbb{I}[\text{act}>1]} \times 1{,}045^{\text{months}} \times 3{,}148^{\mathbb{I}[\text{vol.}]} \times 1{,}126^{\mathbb{I}[\text{East.}]} \times 1{,}214^{\mathbb{I}[\text{sea}]} \times 1{,}065^{\mathbb{I}[\text{rovnost}]} \]

5.2 Koeficienty a jejich přesnost

Zobrazit kód

# Odhady parametrů a jejich multiplikativní interpretace
cf <- summary(model_nointer_final)$coefficients
exp_cf <- exp(coef(model_nointer_final))

# Příprava tabulky odhadů parametrů modelu
tab_koef <- data.frame(
  Proměnná = row.names(cf),
  Odhad_beta = round(cf[, 1], 3),
  exp_beta   = round(exp_cf, 2),
  SE         = round(cf[, 2], 4),
  p_hodnota = case_when(
    cf[, 4] < 0.001 ~ "< 0,001 ***",
    TRUE ~ paste0(
      format(round(cf[, 4], 4), decimal.mark = ",", nsmall = 4),
      case_when(
        cf[, 4] < 0.01 ~ " **",
        cf[, 4] < 0.05 ~ " *",
        cf[, 4] < 0.1  ~ " .",
        TRUE           ~ ""
        )
      )
    )
  )

# Přehlednější názvy proměnných pro výstupní tabulku
coef_rename <- c( "(Intercept)" = "(Konstanta)", 
                 "topic_rovnostTRUE" = "Téma rovnosti v projektu", 
                 "activities_more_than_oneTRUE" = 
                   "Projekt s více než jednou aktivitou",
                 "action_2Volunteering" = "Dobrovolnický projekt", 
                 "eu_subregions_2Eastern" = 
                   "Žadatel z východní Evropy", 
                 "seaTRUE" = "Žadatel z přímořské destinace", 
                 "length_months" = "O jeden měsíc delší projekt" )

# Vykreslení tabulky koeficientů modelu
tab_koef |>
  mutate(across(1, \(x) coalesce(unname(coef_rename[x]), x))) |>
kbl(row.names = FALSE,
    col.names = c("Proměnná", "Koeficient", "Relativní změna", 
                  "Směrodatná chyba", "p-hodnota"),
    align = c("l", "r", "r", "r", "r")) |>
  kable_styling(bootstrap_options = c("striped", "hover")) |>
  column_spec(1, bold = TRUE, monospace = TRUE) |>
  column_spec(5, bold = TRUE, 
              color = ifelse((grepl("\\*|\\.", tab_koef$p_hodnota)), 
                             "#007B3DFF", "gray40"))

Tabulka 5: Koeficienty finálního modelu bez interakcí

Proměnná	Koeficient	Relativní změna	Směrodatná chyba	p-hodnota
(Konstanta)	7,983	2930,02	0,0435	< 0,001 ***
Projekt s více než jednou aktivitou	1,955	7,06	0,0710	< 0,001 ***
O jeden měsíc delší projekt	0,044	1,05	0,0014	< 0,001 ***
Dobrovolnický projekt	1,147	3,15	0,0244	< 0,001 ***
Žadatel z východní Evropy	0,119	1,13	0,0228	< 0,001 ***
Žadatel z přímořské destinace	0,194	1,21	0,0316	< 0,001 ***
Téma rovnosti v projektu	0,063	1,06	0,0202	0,0019 **

Všechny zahrnuté proměnné jsou statisticky významné na 1% hladině významnosti.

5.3 Interpretace koeficientů

Referenční hladinou jsou projekty s jednou akční výzvou (jiná než Volunteering), ze západní Evropy bez přístupu k moři, jejichž téma se netýká rovnosti. Výchozí predikovaná výše grantu je 2 930 €.

Zobrazit kód

# Tabulka multiplikativních efektů: exp(koeficient) | procentní změna | směr efektu
tab_int_data <-
  exp_cf[names(exp_cf) != "(Intercept)"] |>
  (\(cf) tibble(term = names(cf), value = unname(cf)))() |>
  mutate(
    Faktor = coalesce(unname(coef_rename[term]), term),
    Efekt  = paste0(
      "\u00d7 ",
      format(round(value, 2), decimal.mark = ",", drop0trailing = TRUE),
      " (",
      ifelse((value - 1) * 100 >= 0, "+", "\u2212"),
      format(round(abs(value - 1) * 100, 1), 
             decimal.mark = ",", drop0trailing = TRUE),
      " %)"
      ),
    Smer = case_when(
      value > 5 ~ "\u2191\u2191\u2191",
      value > 2 ~ "↑↑",
      value > 1 ~ "↑",
      value < 0.2 ~ "↓",
      value < 0.5 ~ "↓↓",
      TRUE    ~ "→"
      )
    )

# Zobrazení interpretační tabulky efektů
tab_int_data |>
  select(Faktor, Efekt, Smer) |>
  kbl(col.names = c("Faktor / změna", "Multiplikativní efekt na grant", "Směr")) |>
  kable_styling(bootstrap_options = c("striped", "hover"), full_width = FALSE) |>
  column_spec(1, bold = TRUE) |>
  column_spec(2, bold = TRUE,
              color = ifelse(tab_int_data$value >= 1, "#007B3DFF", "#D51317"))

Tabulka 6: Interpretace koeficientů modelu

Faktor / změna	Multiplikativní efekt na grant	Směr
Projekt s více než jednou aktivitou	× 7,06 (+606,1 %)	^^^
O jeden měsíc delší projekt	× 1,05 (+ 4,5 %)	^
Dobrovolnický projekt	× 3,15 (+214,8 %)	^^
Žadatel z východní Evropy	× 1,13 (+ 12,6 %)	^
Žadatel z přímořské destinace	× 1,21 (+ 21,4 %)	^
Téma rovnosti v projektu	× 1,06 (+ 6,5 %)	^

Zobrazit kód

# Skutečná pozorování odpovídající danému scénáři (podklad pro scatter)
red_aktivity <- solidarita_model |>
  filter(action_2 == "Volunteering",
         !topic_rovnost,
         eu_subregions_2 == "Other",
         sea)

# Rozsah délky projektu pro predikční křivky
lm_seq <- seq(1, 37, by = 1)

# Porovnávané scénáře: jedna vs. více aktivit
scen_aktivity <- data.frame(
  activities_more_than_one = c(FALSE, TRUE),
  label                    = c("Jedna aktivita", "Více aktivit")
)

# Predikce výše grantu pro oba scénáře
df_pred_aktivity <- map(1:nrow(scen_aktivity), \(k) {
  nd <- data.frame(
    activities_more_than_one = scen_aktivity$activities_more_than_one[k],
    length_months            = lm_seq,
    action_2                 = "Volunteering",
    eu_subregions_2          = "Other",
    sea                      = TRUE,
    topic_rovnost            = FALSE
  )
  p <- predict(model_nointer_final, newdata = nd, type = "link", se.fit = TRUE)
  data.frame(mesice = lm_seq, fit = exp(p$fit),
             lo = exp(p$fit - 1.96 * p$se.fit),
             hi = exp(p$fit + 1.96 * p$se.fit),
             skupina = scen_aktivity$label[k])
  }) |> 
  list_rbind()

# Převod skupiny na faktor kvůli stabilnímu pořadí v legendě
df_pred_aktivity <- 
  df_pred_aktivity |> mutate(skupina = factor(skupina))

# Predikční graf podle počtu aktivit projektu
p_pred_aktivity <- df_pred_aktivity |>
  ggplot(aes(x = mesice, y = fit, color = skupina, fill = skupina)) +
  geom_point(data = red_aktivity,
             aes(x = length_months, y = eu_grant),
             inherit.aes = FALSE, color = "gray") +
  geom_ribbon(aes(ymin = lo, ymax = hi), color = NA) +
  geom_line(linewidth = 1.1) +
  scale_color_manual(values = setNames(barvy[c(1, 2)],
    c("Jedna aktivita", "Více aktivit"))) +
  scale_fill_manual(values  = setNames(barvy[c(1, 2)],
    c("Jedna aktivita", "Více aktivit"))) +
  scale_y_continuous(labels = label_number(suffix = " tis.", scale = 1e-3),
                     limits = c(0, 550000),
                     breaks = seq(0, 800000, by = 100000)) +
  labs(x = "Délka projektu (měsíce)", y = "Výše grantu (€)",
       color = NULL, fill = NULL) +
  guides(fill = "none") +
  theme(legend.position = "top")

# Interaktivní verze grafu
ggplotly(p_pred_aktivity, tooltip = c("x", "y", "fill")) |>
  style(opacity = 0.5, hoverinfo = "skip", traces = 1) |>
  style(opacity = 0.3, traces = 2:3) |>
  layout(
    annotations = list(
      x = 0.05, y = 0.90, xref = "paper", yref = "paper",
      xanchor = "left", yanchor = "top",
      text = "Akční výzva: Dobrovolnictví<br>Západní Evropa + Sev. Afrika + Bl. východ s mořem<br>Bez zaměření na rovnost",
      showarrow = FALSE, align = "left",
      font = list(size = 11, color = "black"),
      bgcolor = "white", bordercolor = "black"
    )
  ) |>
  config(
    displayModeBar = TRUE,
    displaylogo = FALSE,
    modeBarButtonsToRemove = c(
      "zoom", "toImage", "pan2d", "select2d", "lasso2d", "autoScale2d",
      "hoverClosestCartesian", "hoverCompare"
    )
  )

Obrázek 5: Predikce výše grantu - vliv počtu aktivit (Dobrovolnictví, západní Evropa s mořem, bez rovnosti)

Nejvýznamnějším faktorem je počet aktivit projektu. Projekty s více než jednou aktivitou mají v průměru více než sedminásobnou očekávanou výši grantu oproti projektům s jedinou aktivitou, ale reálně se týká jen 1,85 % projektů. Výrazně vyšší granty získávají také dobrovolnické projekty, jejichž očekávaná výše grantu je až trojnásobná než u ostatních akčních výzev (projekty solidarity nebo stáže a pracovní místa).

Zobrazit kód

# Skutečná pozorování odpovídající danému scénáři (podklad pro scatter)
red_geo <- solidarita_model |>
  filter(
    action_2 == "Volunteering",
    activities_more_than_one == FALSE,
    topic_rovnost == FALSE
  )

# Rozsah délky projektu pro predikční křivky
lm_seq <- seq(1, 37, by = 1)

# Porovnávané scénáře: východ vs. západ, moře vs. bez moře
scen_geo <- expand.grid(
  eu_subregions_2 = c("Eastern", "Other"),
  sea = c(FALSE, TRUE)
)
scen_geo$label <- paste0(
  ifelse(scen_geo$eu_subregions_2 == "Eastern", "Východní", "Západní"),
  " Evropa ",
  ifelse(scen_geo$sea, "s mořem", "bez moře")
)

# Predikce výše grantu pro všechny čtyři scénáře
df_pred_geo <- map(1:nrow(scen_geo), \(k) {
  nd <- data.frame(
    activities_more_than_one = FALSE,
    length_months = lm_seq,
    action_2 = "Volunteering",
    eu_subregions_2 = scen_geo$eu_subregions_2[k],
    sea = scen_geo$sea[k],
    topic_rovnost = FALSE
  )
  p <- predict(model_nointer_final, newdata = nd, type = "link", se.fit = TRUE)
  data.frame(mesice = lm_seq, fit = exp(p$fit),
             lo = exp(p$fit - 1.96 * p$se.fit),
             hi = exp(p$fit + 1.96 * p$se.fit),
             skupina = scen_geo$label[k])
  }) |> 
  list_rbind()

# Převod skupiny na faktor kvůli stabilnímu pořadí v legendě
df_pred_geo <- 
  df_pred_geo |> mutate(skupina = factor(skupina))

# Predikční graf podle geolokace
p_pred_geo <- df_pred_geo |>
  ggplot(aes(x = mesice, y = fit, color = skupina, fill = skupina)) +
  geom_point(data = red_geo,
             aes(x = length_months, y = eu_grant),
             inherit.aes = FALSE, color = "gray50", alpha = 0.25, size = 0.7) +
  geom_ribbon(aes(ymin = lo, ymax = hi), color = NA) +
  geom_line(linewidth = 1.1) +
  scale_color_manual(values = setNames(barvy[c(1,2,5,6)],
    c("Východní Evropa bez moře", "Západní Evropa bez moře",
      "Východní Evropa s mořem", "Západní Evropa s mořem"))) +
  scale_fill_manual(values  = setNames(barvy[c(1,2,5,6)],
    c("Východní Evropa bez moře", "Západní Evropa bez moře",
      "Východní Evropa s mořem", "Západní Evropa s mořem"))) +
  scale_y_continuous(labels = label_number(suffix = " tis.", scale = 1e-3),
                     limits = c(0, 70000)) +
  labs(x = "Délka projektu (měsíce)", y = "Výše grantu (€)",
       color = NULL, fill = NULL) +
  guides(fill = "none") +
  theme(legend.position = "top")

# Interaktivní verze grafu
ggplotly(p_pred_geo, tooltip = c("x", "y", "fill")) |>
  style(opacity = 0.5, hoverinfo = "skip", traces = c(1)) |>
  style(opacity = 0.3, traces = c(2:5)) |>
  layout(
    annotations = list(
      x = 0.05, y = 0.90, xref = "paper", yref = "paper",
      xanchor = "left", yanchor = "top",
      text = "Akční výzva: Dobrovolnictví<br>Jedna aktivita<br>Bez zaměření na rovnost",
      showarrow = FALSE, align = "left",
      font = list(size = 11, color = "black"),
      bgcolor = "white", bordercolor = "black", borderwidth = 1
    )
  ) |>
  config(
      displayModeBar = TRUE,
      displaylogo = FALSE,
      modeBarButtonsToRemove = c(
        "zoom", "toImage", "pan2d", "select2d", "lasso2d", "autoScale2d",
        "hoverClosestCartesian", "hoverCompareCartesian", "toggleSpikelines"
        )
      )

Obrázek 6: Predikce výše grantu - vliv délky projektu a geolokace (Dobrovolnictví, 1 aktivita, bez rovnosti)

Ostatní faktory mají podstatně menší vliv. Delší projekty získávají v průměru o 4,5 % vyšší grant za každý další měsíc trvání. Mírně vyšší granty jsou spojeny také s projekty z východní Evropy (+13 %), ze států s přístupem k moři (+21 %) a s projekty zaměřenými na rovnost (+6 %). Tyto efekty jsou však ve srovnání s počtem aktivit a typem výzvy výrazně slabší.

5.4 Diagnostika modelu

Zobrazit kód

# Diagnostické grafy
par(mfrow = c(1, 3))
plot(model_nointer_final, which = c(1, 3, 5))

Obrázek 7: Diagnostické grafy finálního modelu

Grafy reziduí nevykazují žádný zřejmý vzor – model nevynechává žádnou výraznou systematickou závislost. Pozorování č. 5212 má sice velké reziduum (skutečný grant je 1,8× vyšší, než model predikuje), ale jeho leverage a Cookova vzdálenost jsou malé – výsledky modelu nijak zásadně neovlivňuje.

6 Závěr

6.1 Hlavní zjištění

Program Evropského sboru solidarity je tvořen převážně krátkodobými projekty (50 % délka trvání do 1,5 let, 75 % projektů do 2 let) zaměřenými na vzdělávání, občanství a rovnost. Typický projekt trvá méně než dva roky, realizuje jednu aktivitu a kombinuje několik tematických okruhů současně.

Nejsilnějším prediktorem výše grantu je počet aktivit projektu. Projekty s více než jednou aktivitou získávají výrazně vyšší finanční podporu než projekty s jedinou aktivitou. Vyšší granty jsou dále spojeny s dobrovolnickými projekty, delší dobou realizace, projekty realizovanými ve východní Evropě a projekty ze států s přístupem k moři. Naopak vliv tematického zaměření projektu je relativně slabý.

Z geografického pohledu dominují příjemcům grantů státy jižní a střední Evropy. Přestože nejvíce projektů pochází ze Španělska, Itálie, Německa a Francie, vyšší průměrné granty jsou pozorovány například ve Velké Británii nebo u některých menších zemí. Výše grantu tedy nezávisí pouze na počtu realizovaných projektů, ale také na jejich typu a charakteristikách.

Co zvyšuje výši grantu:

více než jedna aktivita projektu,
dobrovolnická akční výzva,
delší doba realizace projektu,
realizace ve východní Evropě,
realizace ve státě s přístupem k moři,
tematické zaměření na rovnost (slabší efekt).

6.2 Limity analýzy

Z dat byla odstraněna pozorování s chybějícím nebo nulovým grantem (~10 %); pokud tyto hodnoty nejsou zcela náhodné (MCAR), mohou být závěry mírně zkreslené.
Model vysvětluje 63 % variability (pseudo-\(R^2\)) – významná část variability zůstává nevysvětlena a pravděpodobně souvisí s faktory, které dataset neobsahuje (kvalita projektu, hodnoticí proces, specifické cíle projektu apod.).
Analýza vychází z administrativních dat programu a identifikuje statistické souvislosti, nikoli kauzální vztahy.
Proměnná sea pravděpodobně zachycuje širší geografické a socioekonomické charakteristiky zemí (jako přístup ke spolupráci, tradice dobrovolnictví v příbřežních zemích), nikoli přímý vliv přístupu k moři.