--- title: "Faktory související s ochotou vyhledat
odbornou psychologickou pomoc" author: "Anna Smyšlená" date: last-modified date-format: "D. M. YYYY" lang: cs format: html: embed-resources: true toc: true editor: visual editor_options: chunk_output_type: console execute: cache: true quarto: toc-title: "Obsah" knitr: opts_chunk: echo: true comment: "#>" collapse: true fig.show: "hold" fig.width: 6 fig.asp: 0.618 out.width: "100%" fig.align: center csl: apa.csl bibliography: references.bib --- ## Balíčky V rámci analýzy budou použity následující balíčky: *haven* [@haven] pro import dat, *psych* [@psych] pro výpočet odhadů reliability a pro korelační analýzu, *tidyverse* [@tidyverse] pro transformaci dat a tvorbu grafů, apaTables [@apaTables] pro tvorbu regresních tabulek ve formátu APA a balíčky *car* [@car] a *broom* [@broom] pro diagnostiku regresních modelů. ```{r} #| label: setup #| warning: false #| message: false library(haven) library(psych) library(car) library(apaTables) library(tidyverse) ``` ```{r} #| label: ggplot-theme #| include: false theme_update(text = element_text(size = 10), axis.title = element_text(face = "bold"), axis.text = element_text(size = 10), legend.box.background = element_blank(), legend.spacing = unit(0, 'pt'), panel.grid.major = element_blank(), panel.grid.minor = element_blank(), panel.background = element_blank(), axis.line = element_line(colour = "black"), legend.title = element_text(size = 10, face = "bold"), legend.text = element_text(size = 10), strip.text = element_text(face = "bold", size = 10), legend.key = element_rect(fill = "transparent", colour = "transparent"), plot.title.position = "panel") ``` ## Úvod V následující práci se budeme faktory, které souvisejí s ochotou vyhledat odbornou psychologickou pomoc. Konkrétně se zaměříme na pohlaví, věk a vyjadřování emocí (emoční expresivitu). Předpokládáme přitom následující: 1. Muži mají menší ochotu vyhledat odbornou psychologickou pomoc než ženy (H1), protože mají sklon méně emoce vyjadřovat navenek a vyhledání této pomoci mohou častěji chápat jako známku selhání [@pawar2023]. 2. Mladší lidé mají větší ochotu vyhledat odbornou psychologickou pomoc než starší lidé (H2), a to kvůli menší míře stigmatizace duševních poruch u mladší generace [@chen2020]. 3. Emoční otevřenost kladně souvisí s ochotou vyhledat odbornou psychologickou pomoc (H3), protože řešení duševních potíží vyžaduje jistou otevřenost, takže lidé, kteří neradi projevují své emoci, se budou zdráhat služby psychologa využít [@komiya2000]. 4. Emoční otevřenost vysvětluje dodatečný rozptyl v ochotě vyhledat odbornou psychologickou pomoc\ i po kontrole efektu pohlaví a věku (H4). ## Představení dat a plán analýzy ### Sběr dat Data byla získána v rámci předmětu Statistická analýza dat v psychologii. Sběr dat probíhal online metodou příležitostného výběru během listopadu 2022. Respondenti byli oslovování na sociální síti Facebook s prosbou o vyplnění dotazníku zaměřeného na ochotu vyhledat odbornou psychologickou pomoc a faktory, které s ní mohou souviset. Pokud se respondenti rozhodli kliknout na odkaz pro vyplnění dotazníku, byli informováni o tom, že získaná data budou použita pro seminární práci a mohou být dále sdílena pro edukační i vědecké účely. Dále byli respondenti ujištěni o anonymitě výzkumu a požádáni o udělení informovaného souhlasu s účastní na výzkumu a se sběrem a použitím dat. Respondenti, kteří informovaný souhlas udělili, pak mohli pokračovat ve vyplňování samotného dotazníku. První sekce dotazníku tvořily otázky týkající se základních demografických údajů (pohlaví, věk, zda mají partnera/partnerku, zda již mají vysokoškolský titul, zda v současnosti studují na vysoké škole a jak hodnotí svou finanční situaci); druhou sekci dotazníku tvořily položky Škály postojů k vyhledávání odborné psychologické pomoci; a třetí a poslední sekci tvořily položky i Škály emoční otevřenosti ### Nástroje měření *Škála postojů k vyhledávání odborné psychologické pomoci* (Attitudes Towards Seeking Professional Psychological Help -- ATSPPH; @picco2016) měří to, jak respondenti vnímají odbornou psychologickou pomoc (jako je psychologické poradenství či psychoterapie), tj. zda ji považují za přínosnou a užitečnou a byli by ochotni ji využít, nebo nikoli. Obsahuje 10 položek (např. "Kdybych prožíval/a vážnou emoční krizi, jsem si jistý/á, že by mi psychoterapie pomohla"), které jsou hodnoceny odpovědní škála od 1 = "Nesouhlasím" do 4 = "Souhlasím". *Škála emoční otevřenosti* (Emotional Expressivity Scale -- EES; @kring1994) měří sklon vyjadřovat emoce navenek, nebo naopak "držet v sobě". Obsahuje celkem 17 položek (např. "Své emoce projevuji před ostatními lidmi."), které jsou hodnoceny na škále od 1 = "Nikdy pravda" po 7 = "Vždy pravda". ### Import a základní přehled dat Data si nejprve data importujeme do R prostřednictvím balíčku haven, neboť jsou ve formátu, který používá SPSS (.sav). Importovaný dataset si nazveme `df`. ```{r} #| label: data-import # Import dat df <- haven::read_sav("data/help_seeking.sav") glimpse(df) ``` Jak můžeme vidět data obsahují celkem 172 řádků a 33 sloupců, výzkumný soubor tudíž tvořilo *N* = 172 osob. Podíváme se nyní na to, zda se v datech vyskytují nějaké chybějící hodnoty. ```{r} #| label: missing-values df %>% is.na() %>% sum() ``` Jak můžeme vidět, v datech se nenacházejí žádné chybějící hodnoty. Tento výsledek je téměř jistě zapříčiněn tím, že data byla sbírána skrze Google Forms a ty zaznamenávají pouze finalizované dotazníky (když někdo přeruší vyplňování dotazníku a neklikne na tlačítko "odeslat", odpověď se nezaznamená). ### Popis výzkumného souboru Aby se nám s kategorickými proměnnými lépe pracovalo, převedeme si je na faktory. ```{r} #| label: factors df <- df %>% mutate( across(c(gender, partner, starts_with("college"), finantial_situation), as_factor) ) ``` Abychom omezili opakování kódu, vytvoříme si funkci `freq()` pro výpočet absolutních a relativních četností, funkci `ci_mean()` pro výpočet statistik týkajících se průměrů a funkci `quartiles()`pro výpočet kvartilů. ```{r} #| label: custom-functions # Funkce pro výpočet četností freq <- function(...) { df %>% count(...) %>% mutate(prc = n/sum(n)*100) } # Funkce pro výpočet průměrů a dalších statistik pro numerické proměnné ci_mean <- function(x, level = .95, na.rm = TRUE) { if (na.rm == TRUE) { x <- x[!is.na(x)] } n <- length(x) df <- n - 1 s <- sd(x) m <- mean(x) se <- s/sqrt(n) alpha <- 1 - .95 t <- qt(1 - alpha/2, df = df) me <- t*se ci_lower <- m - me ci_upper <- m + me tibble(m = m, ci_lower = ci_lower, ci_upper = ci_upper, sd = s, se = se, n = n, skew = psych::skew(x), kurt = psych::kurtosi(x)) } # Funkce pro výpočet kvartilů quartiles <- function(x, na.rm = TRUE) { tibble( stat = c("Min", "q25", "Mdn", "q75", "Max"), value = quantile(x, probs = c(0, .25, .5, .75, 1), na.rm = na.rm) ) %>% pivot_wider(names_from = stat, values_from = value) } ``` Jak můžeme vidět níže, ženy tvořilo téměř 80 % respondentů a pouze tři osoby se označily za nebinární. Co se týče partnerských vztahů, asi 62 % osob uvedlo, že má v současné době partnera ```{r} #| label: gender-and-partner freq(gender) freq(partner) ``` Věk respondentů se pohyboval od 16 do 78 let (*M* = 30,6, *SD* = 13,3 let), ale rozdělení věku bylo silně pravostranně zešikmené, takže přibližně dvě třetiny respondentů bylo ve věku 16--30 let. ```{r} #| label: age df %>% summarise(ci_mean(age)) df %>% summarise(quartiles(age)) df %>% ggplot(aes(age, y = after_stat(density)*2)) + geom_histogram(binwidth = 2, center = 20, fill = "grey", color = "black") + geom_density(linewidth = 1, color = "red") + labs(x = "Věk v letech", y = "Relativní četnost") + scale_y_continuous(labels = scales::percent, breaks = seq(0, 1, by = 0.05)) + scale_x_continuous(breaks = seq(20, 80, by = 10)) mean(df$age <= 30) ``` Pokud jde o vzdělání, jak můžeme vidět níže, pouze asi 31 % osob uvedlo, že má vysokoškolský titul a přibližně 37 % uvedlo, že v současnosti studuje vysokou školu. ```{r} #| label: education # Vysokoškolský titul freq(college_title) # Studium VŠ v současnosti freq(college_student) ``` Konečně pokud jde o finanční situaci (viz tabulka a graf níže), většina respondentů (69 %) ji hodnotila jako přijatelnou. ```{r} #| label: finantial-situation freq(finantial_situation) df %>% count(finantial_situation) %>% mutate(p = n/sum(n)) %>% ggplot(aes(finantial_situation, p)) + geom_col() + scale_y_continuous(labels = scales::percent) + labs(x = "Finanční situace", y = "Relativní četnost") ``` ### Plán analýzy Nejprve provedeme základní položkovou analýzu ATSPPH a EES a odhadneme reliabilitu (vnitřní konzistenci) obou škál pomocí Cronbachova koeficientu alfa a McDonaldova koeficientu omega. Poté vypočteme celkové skóry obou škál jako průměr položek. Rozdíly mezi muži a ženami v ATSPPH (H1) ověříme pomocí Welchova *t*-testu pro nezávislé výběru. Bivariační vztah mezi věkem a ATSPPH ověříme pomocí Spearmanova korelačního koeficientu a bivariační vztah mezi EES a ATSPPH pomocí Pearsonova korelačního koeficientu. Nakonec pro ověření hypotézy H4 odhadneme lineárně regresní model s ATSPPH jako závislou proměnnou. Prediktory do něj zadáme ve dvou krocích: v prvních kroku do modelu jako prediktory pohlaví a věk, ve druhém kroku EES. ## Výsledky ### Položková analýza Nejdříve si připravíme dva textové vektory s názvy reverzních položek. ```{r} #| label: reversed-items rev_help <- str_c("atspph", str_pad(c(2, 4, 8, 9, 10), pad = 0, width = 2)) rev_emotion <- str_c("ees", str_pad(c(1, 2, 5, 6, 8, 9, 11, 12, 14, 16, 17), pad = 0, width = 2)) ``` Poté skóry reverzních položek obrátíme. ```{r} #| label: recode-reversed-items df <- df %>% mutate( across(all_of(rev_help), ~5 - .x), across(all_of(rev_emotion), ~7 - .x) ) ``` Po rekódování se můžeme podívat na reliabilitu obou škál. ```{r} #| label: reliability df %>% select(starts_with("atspph")) %>% psych::alpha() df %>% select(starts_with("ees")) %>% psych::alpha() ``` Jak můžeme vidět, reliabilita škály ATSPPH byla solidní, Cronbachovo $\alpha$ = 0,82 (95% CI \[0,78; 0,86\]). Všechny položky kladně korelovaly s celkovým skórem škály, ačkoli položka 4 ("Obdivuji lidi, kteří jsou ochotni zvládnout své problémy a starosti, aniž by vyhledali odbornou pomoc.") poměrně slabě (*r* = 0,20). Reliabilita škály EES byla také dobrá, Cronbachovo $\alpha$ = 0,92 (95% CI \[0,90; 0,94\]) a všechny položky korelovaly s celkovým skórem škály kladně. ### Výpočet a přehled celkových skórů Jak bylo řečeno v plánu analýzy, celkové skóry obou použitých škál vypočteme jako průměr položek. ```{r} #| label: compute-total-scores df <- df %>% mutate(help = pick(starts_with("atspph")) %>% rowMeans(), emotion = pick(starts_with("ees")) %>% rowMeans()) ``` Když je máme vypočteny, můžeme se podívat na jejich deskriptivní statistiky a rozdělení. ```{r} #| label: total-scores-stats df %>% pivot_longer(c(help, emotion), names_to = "variable") %>% group_by(variable) %>% summarise(ci_mean(value)) df %>% pivot_longer(c(help, emotion), names_to = "variable") %>% group_by(variable) %>% summarise(quartiles(value)) df %>% ggplot(aes(emotion, y = after_stat(density))) + geom_histogram(binwidth = 0.2, center = 4) + geom_density(color = "red", linewidth = 1) + labs(x = "Emoční otevřenost") df %>% ggplot(aes(help, y = after_stat(density))) + geom_histogram(binwidth = 0.1, center = 2) + geom_density(color = "red", linewidth = 1) + labs(x = "Ochota vyhledat odbnornou psychologickou pomoc") ``` Jak můžeme vidět výše, skóry emoční otevřenosti (EES) byly přibližně normálně rozděleny, zatímco skóry ochoty vyhledat odbnornou psychologickou pomoc byly mírně levostranně zešikmeny, takže se jejich vrchol jejich rozdělení nacházel nad pomyslným středem odpovědní škály (2,5), a to někde okolo hodnoty 3,0. ### Testy hypotéz #### Hypotéza 1 Nejprve se zaměříme na ochotu můžu a žen k vyhledání odborné psychologické pomoci. Vytvoříme si proměnnou `gender_binary`, která bude zahrnovat pouze muže a ženy, protože výzkumný soubor zahrnuje pouze tři nebinární osoby a naše hypotéza se týká pouze mužů a žen. ```{r} #| label: gender-binary df <- df %>% mutate(gender_binary = case_when( gender == "Žena" ~ 1L, gender == "Muž" ~ 2L, TRUE ~ NA_integer_) %>% factor(labels = c("Žena", "Muž"))) ``` Poté se podíváme, jak vypadá rozdělení naší závislé proměnné v obou skupinách. ```{r} #| label: help-by-gender-plots #| fig-asp: 0.5 df %>% drop_na(gender_binary) %>% ggplot(aes(help, y = after_stat(density))) + geom_histogram(binwidth = 0.2) + geom_density(color = "red", linewidth = 1) + facet_wrap(~gender_binary) df %>% drop_na(gender_binary) %>% ggplot(aes(sample = help)) + geom_qq_line(color = "red", linewidth = 1) + geom_qq() + facet_wrap(~gender_binary) ``` Jak můžeme vidět, v obou skupinách je rozdělení ATSPPH podobně negativně zešikmené. Nyní provedeme samotný nezávislý t-test a vypočteme si deskriptivní statistiky. ```{r} #| label: help-by-gender-ttest df %>% drop_na(gender_binary) %>% summarise(ci_mean(help), .by = gender_binary) t.test(help ~ gender_binary, data = df) effectsize::cohens_d(help ~ gender_binary, data = df, pooled_sd = FALSE) ``` Jak můžeme vidět výše, ženy (*M* = 3,08, *SD* = 2,99) vykazovaly v průměru vyšší skór ATSPPH než muži\ (*M* = 3,08, *SD* = 2,50) a tento rozdíl byl statisticky významný, *t*(47) = 3,33, *p* = 0,002. Rozdíl mezi průměry činil $\Delta$*M* = 0,37 (95% CI \[0,14; 0,59\]) a Cohenovo *d* = 0.67 (95% CI \[0,25; 1,08\]). Výsledky tedy podporují hypotézu, že ženy mají větší ochotu vyhledat odbornou psychologickou pomoc než muži. #### Hypotéza 2 Dále se podíváme na vztah mezi věkem a ATSPPH. Nejprve jej prozkoumáme pomocí scatterplotu. ```{r} #| label: help-vs-age-scatterplot #| message: false df %>% ggplot(aes(age, help)) + geom_point(position = position_jitter(seed = 123), alpha = .5, size = 2) + geom_smooth(fill = "red", color = "red", alpha = 0.1) + geom_smooth(fill = "blue", color = "blue", alpha = 0.1, method = "lm", se = F) ``` Jak můžeme vidět, výsledky v tomto případě neodpovídají naší hypotéze, že ochota vyhledat odbnornou psychologickou pomoc je vyšší u mladších lidí. Zdá se naopak, že u starších lidí (nad 25 let) se skór ATSPPH příliš nemění zatímco u osob do 25 let skór ATSPPH s věkem roste. ```{r} #| label: help-age-correlation df %>% select(age, help) %>% psych::cor.ci(plot = FALSE) %>% print(digits = 3) ``` Nicméně Pearsonův korelační koeficient by nasvědčoval pouze slabému a nesignifikantnímu vztahu, *r*(170) = 0,03 (95% CI \[--0,15; 0,18\]), *p* = 0,887. Výsledky tedy nepodporují hypotézu, že starší lidé jsou méně ochotni vyhledat odbornou psychologickou pomoc než lidé mladší. #### Hypotéza 3 Vztah mezi EES a ATSPPH opět prozkoumáme nejdříve pomocí scatterplotu. ```{r} #| label: help-vs-emotion-scatterplot #| message: false df %>% ggplot(aes(emotion, help)) + geom_point(position = position_jitter(seed = 123), alpha = .5, size = 2) + geom_smooth(fill = "red", color = "red", alpha = 0.1) + geom_smooth(fill = "blue", color = "blue", alpha = 0.1, method = "lm", se = F) ``` Jak můžeme vidět, bivariační vztah mezi těmito proměnnými byl kladný a lineární. Pearsonův korelační koeficient by jej tedy měl dobře popsat. ```{r} #| label: help-emotion-correlation df %>% select(help, emotion) %>% psych::cor.ci(plot = FALSE) %>% print(digits = 3) ``` Korelace mezi EES a ATSPPH byla středně silná a signifikantní, *r*(170) = 0,33 (95% CI \[0,20; 0,44\]), *p* \< 0,001. Výsledky tedy podporují hypotézu, že lidé s otevřenějším projevem emocí jsou ochotnější vyhledat odbornou psychologickou pomoc. #### Hypotéza 4 K ověření H4 nejdříve odhadneme model s pohlavím (ženy jsou referenční kategorií) a věkem jako prediktory ATSPPH. ```{r} #| label: lm-model-1 fit1 <- lm(help ~ gender + age, data = df) broom::glance(fit1) broom::tidy(fit1, conf.int = TRUE) %>% mutate(across(where(is.numeric), ~round(.x, digits = 3))) ``` Jak můžeme vidět výše, tento model byl signifikantní, *F*(3; 168) = 4,72, *p* = 0,003 a vysvětloval přibližně 8 % rozptylu. Jediným významným prediktorem zde bylo pohlaví: mužům model predikoval o 0,37 (95% CI \[0,17; 0,57\]) nižší hodnotu ATSPPH než ženám. V druhém kroku jsme jako prediktor přidali skóry EES. ```{r} #| label: lm-model-2 fit2 <- lm(help ~ gender + age + emotion, data = df) broom::glance(fit2) broom::tidy(fit2, conf.int = TRUE) %>% mutate(across(where(is.numeric), ~round(.x, digits = 3))) anova(fit1, fit2) ``` Jak můžeme vidět výše, po přidání EES jako prediktoru se podíl vysvětleného rozptylu zvýšil přibližně na 16 % a tento přírůstek byl statisticky významný, *F*(1, 167) = 16,48, *p* \< 0,001. V souladu s očekáváním emoční otevřenost kladně souvisela s ochotou vyhledat odbornou psychologickou pomoc. Zvýšení EES o jeden bod bylo spojeno s průměrným přírůstkem ATSPPH přibližně o 0,18 bodu (95% CI \[0,09; 0,26\]). Tabulka níže pro lepší přehled zobrazuje *b*-koeficienty a semiparciální korelace koeficientů obou modelů, ale také podíly vysvětleného rozptylu a přírůstek vysvětleného rozptylu společně s 95% intervaly spolehlivosti. ```{r} #| label: apa-reg-table apaTables::apa.reg.table(fit1, fit2) ``` K ověření předpokladu linearity můžeme použít tzv. ceres grafy. Jak můžeme vidět, vztah mezi EES a ATSPPH byl lineární, zatímco linearitu vztahu mezi věkem a ATSPPH mírně narušovalo to, čeho už jsme si všimli dříve: u starších lidí (nad 25 let) se skór ATSPPH příliš neměnil v závislosti na věku, zatímco u osob do 25 let skór ATSPPH s věkem mírně vzrůstal. ```{r} #| label: ceres-plots #| warning: false #| fig-asp: 1.5 car::ceresPlots(fit2, layout = c(2, 1)) ``` S multikolinearitou náš model problém neměl, soudě podle hodnoty Variance Inflation Factor, které se odchylují od 1 jen zanedbatelně, jak můžeme vidět níže. ```{r} #| label: vif car::vif(fit2) ``` Nezávislost mezi sousedními rezidui jsme ověřili pomocí Durbin-Watsonova testu. Jak můžeme vidět níže, korelace mezi sousedními rezidui byla mizivá. ```{r} #| label: durbin-watson-test car::durbinWatsonTest(fit2) ``` Co se týče normality reziduí, jak ukazuje histogram a Q-Q graf níže, jejich rozdělení bylo jen mírně negativně zešikmené. ```{r} #| label: residuals-distribution #| fig-asp: 0.8 fit2 %>% resid() %>% scale() %>% hist(main = NULL) car::qqPlot(fit2) ``` Graf reziduí a predikovaných hodnot (viz níže) pak nenasvědčoval tomu, že rozptyl reziduí je konstantní a nezávisí na predikované hodnotě. ```{r} #| label: residuals-vs-fitted #| fig-asp: 0.8 plot(fit2, 1) ``` Jak ukazuje graf níže, některé případy vykazovaly vysoké reziduum a některé vysokou hodnotu leverage, ale žádné nevykazovaly kombinaci vysokého rezidua a vysoké hodnoty leverage. Případy napravo (s čísly 49, 50 a 26) jsou jedinými zástupci své kategorie (tři osoby s nebinárním pohlavím), a proto mají zákonitě vysokou hodnotu leverage. ```{r} #| label: extreme-cases df_augment <- broom::augment(fit2) %>% mutate(id = row_number()) df_augment %>% ggplot(aes(.hat, .std.resid, size = .cooksd)) + geom_text(aes(label = id)) ``` I kdybychom vyřadili extrémní a vlivné případy (26, 49, 50 a 155), regresní analýza by vedla ke stejným výsledkům, jak můžeme vidět níže. ```{r} #| label: sensitivity-analysis df_augment %>% filter(.hat < 0.3, abs(.std.resid) < 3) %>% lm(help ~ gender + age + emotion, data = .) %>% summary() ``` ## Závěry Výsledky podpořily naše hypotézy, že ženy vykazují vyšší ochotu vyhledat odbornou psychologickou pomoc než muži a že emoční otevřenost kladně souvisí s ochotou vyhledat tuto pomoc, a to i po kontrole efektu věku a pohlaví. Hypotéza, že starší lidé mají nižší ochotu vyhledat odbornou psychologickou pomoc, ovšem podpořena nebyla. Ve skutečnosti jsme pozorovali určitý trend, kdy ochota vyhledat odbornou psychologickou pomoc mírně rostla s věkem u osob přibližně do 25 roku věku, ale u osob nad 25 let byl vztah mezi věkem a ochotou vyhledat psychologickou pomoc zanedbatelný. Co se týče statistických limitů, při ověřování rozdílu mezi muži a ženami pomocí nezávislého *t*-testu bylo rozdělení závislé proměnné u mužů a žen mírně negativně zešikmené. Ale vzhledem k tomu, že tvar rozdělení byl u osobu skupin podobný, měly být být výsledky *t*-testu robustní. Ačkoli rozdělení reziduí z lineárně regresního modelu bylo mírně zešikmené a v datech se vyskytlo několik extrémních či vlivných případů, výsledky rovněž považujeme za robustní, protože (a) odchylky od normality byly poměrně malé; (b) vzorek zahrnoval více než 100 osob a nároky na normalitu s velikostí vzorku klesají; (c) i po vyřazení extrémních a vlivných případů by regresní analýza vedla k totožným závěrům. #### Session info Pro reprodukovatelnost uvádíme tzv. session info, obsahující informace o R, operačním systému a všech načtených balíčcích. ```{r} #| label: session-info sessionInfo() ``` # Literatura