```{r setup, message=FALSE,warning=FALSE, results="hide", echo = FALSE}
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.
```{r nacist_data, cache=TRUE, message=FALSE}
source(here::here("datasety_dotaznik.R"), encoding = "UTF-8")
```
```{r, cache = FALSE}
# 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
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ší :-)
```{r celkove-pocty}
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:
```{r celkove-15-az-26}
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")
```
```{r}
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.
```{r dle-pohlavi}
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.
```{r vekove-rozlozeni}
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.
```{r zivotni-faze}
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.
```{r roverska-zkusenost}
plot_summary_mc(hlavni_data, kategorie_respondenta_full, "Roverská zkušenost")
```
## Reprezentativnost
```{r, results="hide", message=FALSE}
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.
```{r}
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
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.
```{r}
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")
```
```{r}
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á.
```{r}
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.
```{r}
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.
```{r}
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ší.
```{r}
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.
```{r}
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.
```{r}
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")
```
```{r}
# 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.
```{r}
hlavni_data %>% group_by(sex) %>% summarise(prumer_vek = mean(age), .groups = "drop") %>% table_format()
```
## Střediska
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.
```{r}
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).
```{r}
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
```
```{r}
# 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)
```
Sign in with Wallet
Connect another wallet