In martinmodrak/revize-rs: Code for analysis of revize-rs project data

source(here::here("setup_dotaznik.R"), encoding = "UTF-8")
knitr::opts_chunk$set(echo = FALSE, cache=TRUE)

Velký průzkum --- kdo odpovídal? {#charakteristika-respondentu}

V této kapitole se věnujeme obecným charakteristikám respondentů a klademe si otázku, jak moc může být průzkum (ne)reprezentativní vůči naší cílové populaci, tedy všem členům a členkám Junáka ve věku 15-26 let.

source(here::here("datasety_dotaznik.R"), encoding = "UTF-8")

# Je z nejakeho duvodu potreba, aby fungovalo get_default_zaloha_labels pri export do Wordu
assign("zaloha_labels", zaloha_labels, envir = globalenv())

Celkové počty {#celkove-pocty}

Dotazník měl delší a kratší verzi. Těch, co vyplnili verzi kratší jsme se pak ještě zeptali, jestli přeci jen nechtějí pokračovat a vyplnit delší :-)

datasety_wide$pouzitelne %>% group_by(stav_vyplneni) %>% summarise(pocet = n(), .groups = "drop") %>%
  mutate(stav_vyplneni = factor(stav_vyplneni, levels = c("nedokoncil","dokoncil_kratsi", "rozpracoval_doplnek", "dokoncil_doplnek", "dokoncil_delsi"), labels = c("Nedokončil ale vyplnil aspoň něco", "Dokončil kratší a nepokračoval", "Dokončil kratší a nedokončil pokračování", "Dokončil kratší i pokračování", "Dokončil delší"))) %>%
  ggplot(aes(x = stav_vyplneni, y = pocet, label = pocet)) + geom_bar(stat = "identity") + 
  geom_text(aes(color = pocet > 50), y = 50, hjust = 0, family = title_family(), size = 6) + 
              coord_flip() + vodorovne_popisky_x + expand_limits(y = 1330) +
  scale_color_manual(values = c("white", revize_cols("dark_blue")), guide = FALSE) +
    theme(axis.title = element_blank(), axis.text.x = element_blank(),
          axis.ticks.x = element_blank(), axis.line.x = element_blank()) +
  plot_annotation("Počet vyplnění", subtitle = "Všichni")

V datech dále primárně analyzujeme jen respondenty ve věku 15 --- 26 let, tam počty vypadaji takto:

datasety_wide$pouzitelne %>%  filter(age >= 15, age <= 26) %>% group_by(stav_vyplneni) %>% summarise(pocet = n(), .groups = "drop") %>%
  mutate(stav_vyplneni = factor(stav_vyplneni, levels = c("nedokoncil","dokoncil_kratsi", "rozpracoval_doplnek", "dokoncil_doplnek", "dokoncil_delsi"), labels = c("Nedokončil ale vyplnil aspoň něco", "Dokončil kratší a nepokračoval", "Dokončil kratší a nedokončil pokračování", "Dokončil kratší i pokračování", "Dokončil delší"))) %>%
  ggplot(aes(x = stav_vyplneni, y = pocet, label = pocet)) + geom_bar(stat = "identity") + 
  geom_text(aes(color = pocet > 50), y = 50, hjust = 0, family = title_family(), size = 6) + 
              coord_flip() + vodorovne_popisky_x + expand_limits(y = 1330) +
  scale_color_manual(values = c("white", revize_cols("dark_blue")), guide = FALSE) +
    theme(axis.title = element_blank(), axis.text.x = element_blank(),
          axis.ticks.x = element_blank(), axis.line.x = element_blank()) +
  plot_annotation("Počet vyplnění", subtitle = "Jen 15-26")

podil_z_registrovanych_roveru <- nrow(hlavni_data) / 12924

Ty, kteří dotazník nedokončili budeme z většiny analýz vyřazovat. Zbývá nám tak r nrow(hlavni_data) vyplněných dotazníků, což je r scales::percent(podil_z_registrovanych_roveru) ze všech registrovaných skautů v roverském věku (nicméně někteří z těch, kteří dotazník vyplnili, nejsou registrovaní).

Rozložení dle pohlaví ukazuje převahu žen (což je rozdíl oproti registraci, kde v této věkové kategorii převažují muži). Členů, kteří se do binární škatulky pohlaví nezařadí máme kolem 1%, což odpovídá odhadům tohoto podílu v běžné populaci.

hlavni_data %>%
  group_by(sex) %>%
  summarise(n = n(), .groups = "drop") %>%
  mutate(sex_factor = factor(sex, levels = c("jinak_neuvedeno","muz", "zena"), labels = c("Je to jinak/nepřeji si uvést","Muž","Žena"))) %>%
  ggplot(aes(x = "", y = n, fill = sex_factor)) + geom_bar(stat = "identity") + coord_polar("y", start = 0) + scale_fill_manual("", values = revize_cols("darkest_fill","mid_fill","white")) + 
  geom_text(aes(y = sum(n) - n/2 - 65 - c(0, cumsum(n)[-length(n)]), 
            label = scales::percent(n/sum(n))), color = revize_cols("dark_blue"), x = 1, size=5, family = "Roboto", fontface = "bold") +
  theme(axis.text = element_blank(), axis.ticks = element_blank(), axis.line = element_blank(),
        axis.title = element_blank()) +
  plot_annotation("Respondenti dle pohlaví")

S velkou omluvou směrem k respondentům, kteří si nepřáli kategorizovat svoje pohlaví na muž/žena je z grafů, ve kterých ukazujeme pohlaví zvlášť, vynecháváme. Vzhledem k malému počtu těchto respondentů mají výrazně větší rozpětí nejistoty, což činí grafy méně čitelnými. Zároveň skutečně o této skupině nemůžeme v porovnání s ostatními kvůli tomuto malému počtu říct nic s jistotou.

Takto vypadá rozložení respondentů dle věku --- přerušované čáry ukazují rozmezí 15 --- 26 let, tj. skupinu, kterou primárně analyzujeme.

datasety_wide$pouzitelne %>% group_by(age) %>% summarise(pocet = n(), .groups = "drop") %>% mutate(podil = pocet / sum(pocet)) %>%
  ggplot(aes(x = age, y = podil, label = scales::percent(podil, accuracy = 1))) + geom_bar(stat = "identity") + #geom_text(aes(y = 0.01), color = revize_cols("dark_blue"), size = 6 ) + 
  vodorovne_popisky_x + scale_y_continuous("Podíl", labels = scales::percent) + scale_x_continuous("Věk") + plot_annotation("Věkové rozložení respondentů") + geom_vline(xintercept = 14.5) + geom_vline(xintercept = 26.5)

Životní fáze --- tady už se opět díváme jen na respondenty 15---26 let.

hlavni_data %>% plot_summary_mc(zivotni_faze, "Životní fáze")

A jedna z hlavních otázek, kterou charakterizujeme respondenty je jejich dosavadní roverská zkušenost.

plot_summary_mc(hlavni_data, kategorie_respondenta_full, "Roverská zkušenost")

Reprezentativnost

source(here::here("R","data_registrace_jednotlivci.R"), encoding = "UTF-8")
data_skautis_jednotlivci_raw <- registrace_jednotlivci()
data_skautis_jednotlivci <- data_skautis_jednotlivci_raw %>%
  filter(Year == 2018) %>%
  select(Year, Person_PseudoID, vek, ID_Sex) %>% distinct() %>%
  mutate(sex = if_else(ID_Sex == "female", "zena", "muz"))

V každém obrázku níže je křivka "SkautIS", která reprezentuje podíl dané skupiny členstva v datech ze SkautISu (vůči všem registrovaným 15---26 let). Tato křivka má kolem sebe pruh vyjadřující nejistotu --- jak velký rozptyl bychom čekali, kdybychom vybrali ze SkautISu náhodně tolik lidí, kolik jich bylo v daném průzkumu. Druhá křivka vyjadřuje podíl dané skupiny, který jsme viděli v průzkumu. V zásadě lze říct, že když se křivka průzkumu vejde do pruhu kolem dat ze SkautISu, je výzkum v tomto ohledu slušně reprezentativní.

Jak uvidíme níže, většina křivek se nám hezky překrývá, ale máme několik --- dle našeho názoru spíše méně zásadních --- odchylek od skautské populace dle registrace.

Detailně dle věku {#reprezentativnost-vek}

Z věkových skupin máme podreprezentovány patnáctileté. To není překvapení. Tím, že jsou na hraně roverského věku, čekáme, že se k nim průzkum vůbec nemusel dostat. Zato máme o něco více “prostředních roverů”. Zajímavé ale je, že primárně jde o nedostatek 15ti letých roverů (mužů) a v “prostředním” věku naopak o nadbytek rangers/roverek. Doplním, že detailní data o věku máme jen z registrace 2018, takže tu může být jistý nesoulad se stavem k době průzkumu.

reprezentativnost_vek <- function(data_skautis_, data_pruzkum_, min_vek = 15, max_vek = 26, additional_group = "Vše") {
  dle_veku_pruzkum <- data_pruzkum_ %>% mutate(vek = age) %>%
    filter(!is.na(vek), vek >= min_vek, vek <= max_vek) %>%
    group_by(vek, {{additional_group}}) %>%
    summarise(clenu = length(vek), .groups = "drop") %>% ungroup() %>% 
    mutate(zdroj = "Průzkum", 
           group = {{additional_group}})

  dle_veku_skautis <-  data_skautis_ %>%
    filter(vek >= min_vek, vek <= max_vek) %>%
    group_by(vek, {{additional_group}}) %>%
    summarise(clenu = length(vek), .groups = "drop") %>% 
    ungroup() %>%
    mutate(zdroj = "SkautIS", 
           group = {{additional_group}}) 

dle_veku <- rbind(dle_veku_pruzkum, dle_veku_skautis) 

celkem <- dle_veku %>% group_by(zdroj) %>% summarise(celkem_v_datech = sum(clenu), .groups = "drop")

dle_veku <- dle_veku %>%
  inner_join(celkem, by = c("zdroj" = "zdroj")) %>% 
  mutate(podil = clenu / celkem_v_datech)

confidence <- dle_veku %>% filter(zdroj == "Průzkum") %>%
  inner_join(
    dle_veku %>% filter(zdroj == "SkautIS") %>% 
      select(vek, podil, group) %>%
      rename(podil_skautis = podil)
      , 
    by = c("vek" = "vek", "group" = "group")) %>%
  mutate(
    conf_lower = qbinom(0.025, celkem_v_datech, podil_skautis) / celkem_v_datech,
    conf_upper = qbinom(0.975, celkem_v_datech, podil_skautis) / celkem_v_datech,
    zdroj = "SkautIS",
  )


dle_veku %>% 
  ggplot(aes(x=vek, y = podil, color = zdroj, fill = zdroj, group = zdroj )) + 
  geom_ribbon(data = confidence, aes(ymin = conf_lower, ymax = conf_upper), alpha = 0.2, color = "transparent") +
  geom_line() + scale_color_revize() + scale_fill_revize() + vodorovne_popisky_x +
  facet_wrap(~group) + scale_y_continuous(labels = scales::percent)
}

reprezentativnost_vek(data_skautis_jednotlivci, hlavni_data) + plot_annotation("Reprezentativnost průzkumu dle věku")



reprezentativnost_vek(data_skautis_jednotlivci, hlavni_data %>% filter(sex != "jinak_neuvedeno"), additional_group = sex) + plot_annotation("Reprezentativnost dle věku a pohlaví")

Dle kraje, velikosti střediska {#reprezentativnost-kraj-stredisko}

Zde vycházíme z open dat ze SkautISu --- používáme data z registrace 2019, v době zpracování ještě novější nebyly k dispozici.

strediska_kraje <- nacti_strediska_kraje()

registrace_strediska <- nacti_skautis_pocty_clenu(here("public_data/pocet-clenu-strediska-2019.csv")) %>% filter(Year == 2019, ID_UnitType == "stredisko") %>% inner_join(strediska_kraje, by = c("RegistrationNumber")) %>%
  transmute(kraj = UnitName_kraj,
            pocet_clenu_strediska =   cut(RegularMembers, breaks = c(0, 70, 100, 130, 200, 1e4),
                                    labels = manual_codings$pocet_clenu_strediska),
            do_18 = RegularMembersTo18,
            nad_18 = RegularMembersTo26
            ) %>%
  pivot_longer(one_of(c("do_18","nad_18")), names_to = "vekova_skupina", values_to = "pocet_clenu")

compute_reprezentativnost_data <- function(hlavni_data, registrace_strediska, cols) {
  respondenti_seskupeno <- hlavni_data %>%
    mutate(vekova_skupina = if_else(age <= 18, "do_18", "nad_18")) 


  if("kraj" %in% cols) {
    respondenti_seskupeno <- respondenti_seskupeno %>%
      filter(!is.na(kraj), !grepl("Nejsem", kraj)) #Grepl je tu místo  != "Nevím/Nejsem součástí žádného střediska" protože utf-8
  }
  if("pocet_clenu_strediska" %in% cols) {
    respondenti_seskupeno <- respondenti_seskupeno %>%
      filter(pocet_clenu_strediska != explicit_na_level)
  }


  respondenti_seskupeno <- respondenti_seskupeno %>%
    mutate(kraj = as.character(kraj)) %>%
    group_by_at(all_of(cols)) %>%
    summarise(pocet_respondentu = n(), .groups = "drop") %>%
    ungroup() %>%
    droplevels()




  skautis_seskupeno <- registrace_strediska %>% 
    group_by_at(all_of(cols)) %>%
    summarise(pocet_skautis = sum(pocet_clenu), .groups = "drop") %>%
    ungroup()

  reprezentativnost_data <- skautis_seskupeno %>% 
    left_join(respondenti_seskupeno, by = cols) %>%
    ungroup() %>%
    mutate(pocet_respondentu = if_else(is.na(pocet_respondentu), 0L, pocet_respondentu),
           podil_respondentu = pocet_respondentu / sum(pocet_respondentu),
           podil_skautis = pocet_skautis / sum(pocet_skautis),
           conf_lower = qbinom(0.025, sum(pocet_respondentu), podil_skautis) / sum(pocet_respondentu),
           conf_upper = qbinom(0.975, sum(pocet_respondentu), podil_skautis) / sum(pocet_respondentu)
           )

  if(nrow(skautis_seskupeno) != nrow(reprezentativnost_data) ||  sum(reprezentativnost_data$pocet_respondentu > 0) != nrow(respondenti_seskupeno)) {
    cat(nrow(skautis_seskupeno), nrow(reprezentativnost_data), sum(reprezentativnost_data$pocet_respondentu > 0), nrow(respondenti_seskupeno))
    stop("Spatny join")
  }

  if("kraj" %in% cols) {
    reprezentativnost_data <- reprezentativnost_data %>% 
      mutate(kraj = gsub("Hlavní město | ?kraj ?", "", kraj))
  }

  reprezentativnost_data
}

plot_reprezentativnost <- function(reprezentativnost_data, facet = NULL, x = kraj) {
  reprezentativnost_data %>% 
    select(-starts_with("conf_")) %>%
    rename(podil_SkautIS = podil_skautis, `podil_Pruzkum` = podil_respondentu) %>%
    pivot_longer(starts_with("podil_"), names_to = "zdroj", values_to = "podil", names_prefix = "podil_") %>%
    ggplot(aes(x= {{x}}, y = podil, color = zdroj, fill = zdroj, group = zdroj ))  + 
    geom_line()+ 
    geom_ribbon(data = reprezentativnost_data %>% mutate(zdroj = "SkautIS", podil = podil_skautis), aes(ymin = conf_lower, ymax = conf_upper), alpha = 0.5, color = "transparent")  + scale_color_revize() + scale_fill_revize() +
    facet + scale_y_continuous(labels = scales::percent)
}

Kraje máme poměrně dobře zastoupené --- vidíme drobně nadreprezentovaný Jihomoravský a drobně podreprezentovaný Plzeňský a Zlínský, ale na zásadní problém to nevypadá.

compute_reprezentativnost_data(hlavni_data, registrace_strediska, cols = c("kraj")) %>%
  plot_reprezentativnost() + plot_annotation("Reprezentativnost dle kraje")

Různé velikosti středisek jsou taky zastoupeny celkem rozumně, jakkoliv kategorie 70 --- 100 a 100 --- 130 členů jsou mírně nadreprezentovány na úkor kategorie 130 --- 200.

compute_reprezentativnost_data(hlavni_data, registrace_strediska, cols = c("pocet_clenu_strediska")) %>%
  plot_reprezentativnost(x = pocet_clenu_strediska) + plot_annotation("Reprezentativnost", "dle velikosti střediska")

Kraj můžeme kombinovat s věkovou skupinou (SkautIS open data nám říká jen 15 --- 18 a 19---26). Dalším dělením trochu ztrácíme na citlivosti (rozšiřuje se pruh nejistoty), nicméně se nezdá, že by po rozdělení podle věku data vypadala hůře.

compute_reprezentativnost_data(hlavni_data, registrace_strediska, cols = c("vekova_skupina","kraj")) %>%
  plot_reprezentativnost(facet_wrap( ~ vekova_skupina)) + plot_annotation("Reprezentativnost dle kraje, věku")

Obdobně můžeme rozdělit reprezentativnost dle velikosti střediska. Zde to vypadá, že v kategorii nad 18 let je reprezentativnost o něco lepší.

compute_reprezentativnost_data(hlavni_data, registrace_strediska, cols = c("pocet_clenu_strediska", "vekova_skupina")) %>%
  plot_reprezentativnost(facet = facet_wrap(~ vekova_skupina),x = pocet_clenu_strediska) + plot_annotation("Reprezentativnost", "dle velikosti střediska")

Můžeme též zkombinovat kraj a velikost střediska --- opět ztrácíme citlivost. Nicméně je zde vidět například to, že nadreprezentování Jihomoravského kraje je hnáno velkými středisky. Opět neukazuje na podstatný problém s reprezentativností dat.

compute_reprezentativnost_data(hlavni_data, registrace_strediska, cols = c("pocet_clenu_strediska","kraj")) %>%
  plot_reprezentativnost(facet_wrap( ~ pocet_clenu_strediska, nrow = 1)) + plot_annotation("Reprezentativnost", "dle kraje, velikosti střediska")

A samozřejmě ještě můžeme rozdělit dle věkové skupiny (zde ve dvou obrázcích), ale už nám to moc nového nepřinese.

reprezentativnost_data_vse <- compute_reprezentativnost_data(hlavni_data, registrace_strediska, cols = c("vekova_skupina","kraj", "pocet_clenu_strediska"))

plot_reprezentativnost(reprezentativnost_data_vse %>% filter(vekova_skupina == "nad_18"), facet_wrap( ~ pocet_clenu_strediska, nrow = 1)) + plot_annotation("Reprezentativnost nad 18", "dle kraje a velikosti střediska")



plot_reprezentativnost(reprezentativnost_data_vse %>% filter(vekova_skupina == "do_18"),  facet_wrap( ~ pocet_clenu_strediska, nrow = 1))  + plot_annotation("Reprezentativnost pod 18", "dle kraje a velikosti střediska")

# TODO: Je ostrý odpad lidí u vyplnění kompetencí?

Celkově je reprezentativnost dat celkem dobrá. Budeme tedy většinou uvádět přímo data z dotazníku a ne data "přeškálovaná" na hypotetickou kompletní populaci --- neočekáváme, že by to udělalo velký rozdíl a přineslo by to další práci a možné chyby do analýzy.

Jedinou výjimkou z tohoto je potřeba velké opatrnosti při porovnání mezi pohlavími, protože respondenti-muži jsou v průměru o něco starší než respondenti-ženy. Tedy porovnání pohlaví musí vždy zohlednit věk.

hlavni_data %>% group_by(sex) %>% summarise(prumer_vek = mean(age), .groups = "drop") %>% table_format()

Střediska {#respondenti-strediska}

Respondenti měli více způsobů jak vyplnit informace o středisku --- buď přímo registrační číslo, nebo naopak odpovědět na otázky o počtu členů apod.

  plot_summary_mc(hlavni_data, typ_id_strediska, order_by_podil = FALSE, invert_color_threshold =  0.03, title = "Vyplnění informací o středisku")

pocet_vyplnenych_reg_c <- sum(!is.na(hlavni_data$reg_c_strediska))

Seznam středisek ze kterých máme nejvíce respondentů asi nepřekvapí (Blaník). Čísla je navíc potřeba brát s ohledem na to, že detailní informace o středisku nám vyplnilo jen r pocet_vyplnenych_reg_c respondentů (tj. necelá polovina).

if(is.null(hlavni_data$reg_c_strediska)) {
 warning("Anonymizovana data neobsahuji detaily strediska") 
} else {
  hlavni_data %>% group_by(reg_c_strediska) %>% summarise(pocet = n(), nazev = nazev_strediska[1], .groups = "drop") %>% filter(!is.na(reg_c_strediska), pocet > 8) %>% arrange(desc(pocet)) %>% table_format
}

# TODO: jak moc se schoduji odpovedi různých lidí ze stejného střediska?
# 
# TODO: člen společenství --- role vs. kategorie respondenta
# 
# TODO: byla by dobrá reprezentativnost dle hotových kurzů/zkoušek (ale to by potřebovalo data ze SkautISu)

martinmodrak/revize-rs documentation built on March 9, 2021, 5:30 a.m.