Prevents enkät för organisatorisk och social arbetsmiljö

Code

library(foreign)
library(readxl)
library(RISEkbmRasch) # devtools::install_github("pgmj/RISEkbmRasch")
library(grateful) 
library(ggrepel)
library(car)
library(kableExtra)
library(readxl)
library(tidyverse)
library(eRm)
library(mirt)
library(psych)
library(ggplot2)
library(psychotree)
library(matrixStats)
library(reshape)
library(knitr)
library(cowplot)
library(formattable) 
library(glue)
library(hexbin)
library(skimr)


### some commands exist in multiple packages, here we define preferred ones that are frequently used
select <- dplyr::select
count <- dplyr::count
recode <- car::recode
rename <- dplyr::rename

# file paths will need to have "../" added at the beginning to be able to render document

# get itemlabels
itemlabels <- read_excel("../data/Itemlabels.xlsx") %>% 
  filter(str_detect(itemnr, pattern = "abk")) %>% 
  select(!Dimension)

spssDatafil <- "../data/2023-04-26 Prevent OSA-enkat.sav"

# read SurveyMonkey data
df <- read.spss(spssDatafil, to.data.frame = TRUE) %>% 
  select(starts_with("q0006"),q0001,q0002,q0003,q0004) %>% 
  rename(Kön = q0002,
         Ålder = q0001,
         Bransch = q0003,
         Hemarbete = q0004)



# SPSS format provides itemlabels too, we can save them in a dataframe
spssLabels <- df %>% attr('variable.labels') %>% as.data.frame()

dif.kön <- df$Kön
dif.ålder <- df$Ålder
dif.bransch <- df$Bransch
dif.hemarbete <- df$Hemarbete

df <- df %>% 
  select(starts_with("q0006"))

names(df) <- itemlabels$itemnr

3.1 Items

Code

itemlabels %>% 
  kbl_rise(width = 60)

itemnr	item
abk1	Min arbetsbelastning är rimlig.
abk2	Jag hinner med mina arbetsuppgifter inom min arbetstid.
abk3	Mitt arbete är lagom omväxlande.
abk4	Jag upplever att andras krav på mig är rimliga.
abk5	Jag kan få hjälp om min arbetsbelastning är för hög.
abk6	Mitt arbete är fritt från psykiskt påfrestande arbetsuppgifter.

3.2 Bakgrundsdata

Code

RIdemographics(dif.kön,"Kön")

Kön	n	Percent
Kvinna	402	69.7
Man	172	29.8
Annat	1	0.2
Vill ej uppge	2	0.3

Code

RIdemographics(dif.ålder,"Ålder") # kanske även fixa en figur?

Ålder	n	Percent
18-29	22	3.8
30-39	103	17.8
40-49	175	30.2
50-59	215	37.1
60+	64	11.1

Code

RIdemographics(dif.bransch,"Bransch")

Bransch	n	Percent
Kontorsarbete (oavsett bransch)	284	49.1
Industri	26	4.5
Hotell, restaurang, service	8	1.4
Handel	16	2.8
Skola, utbildning	67	11.6
Vård, omsorg	99	17.1
Byggverksamhet	7	1.2
Annat	71	12.3

Code

RIdemographics(dif.hemarbete,"Antal dagar med arbete hemifrån")

Antal dagar med arbete hemifrån	n	Percent
En dag	136	23.5
Två dagar	105	18.1
Tre dagar	35	6.0
Fyra dagar	10	1.7
Fem dagar	2	0.3
Jag arbetar aldrig eller sällan hemifrån	291	50.3

3.2.1 Svarsbortfall items

Vi filtrerar bort respondenter som har färre än två svar på frågorna i delskalan.

Code

# If you want to include participants with missing data, input the minimum number of items responses that a participant should have to be included in the analysis:
min.responses <- 2
scale.items <- itemlabels$itemnr

# Select the variables we will work with, and filter out respondents with a lot of missing data
df.omit.na <- df %>% 
  filter(length(scale.items)-rowSums(is.na(.[scale.items])) >= min.responses)

RImissing(df.omit.na,"abk")

Vi har extremt få saknade svar, och tar därför bort respondenterna som inte har kompletta svar.

Code

df <- read.spss(spssDatafil, to.data.frame = TRUE) %>% 
  select(starts_with("q0006"),q0001,q0002,q0003,q0004) %>% 
  rename(Kön = q0002,
         Ålder = q0001,
         Bransch = q0003,
         Hemarbete = q0004) %>% 
  na.omit()

dif.kön <- df$Kön
dif.ålder <- df$Ålder
dif.bransch <- df$Bransch
dif.hemarbete <- df$Hemarbete

df <- df %>% 
  select(starts_with("q0006"))

names(df) <- itemlabels$itemnr

df.omit.na <- df

3.2.2 Alla svar för alla frågor

Code

RIallresp(df.omit.na)

Response category	Number of responses	Percent
Alltid	520	17.0
Mycket ofta	927	30.2
Ganska ofta	799	26.1
Ibland	440	14.4
Sällan	304	9.9
Aldrig	76	2.5

Code

# koda om svarskategorier till siffror
df.omit.na <- df.omit.na %>% 
  mutate(across(everything(), ~ car::recode(.x,"'Aldrig'=0;
                                            'Sällan' =1;
                                            'Ibland'=2;
                                            'Ganska ofta'=3;
                                            'Mycket ofta'=4;
                                            'Alltid'=5",
                                            as.factor = FALSE)))

3.2.3 Descriptives - all items

itemnr	item
abk1	Min arbetsbelastning är rimlig.
abk2	Jag hinner med mina arbetsuppgifter inom min arbetstid.
abk3	Mitt arbete är lagom omväxlande.
abk4	Jag upplever att andras krav på mig är rimliga.
abk5	Jag kan få hjälp om min arbetsbelastning är för hög.
abk6	Mitt arbete är fritt från psykiskt påfrestande arbetsuppgifter.

Code

RItileplot(df.omit.na)

Code

RIbarstack(df.omit.na) + ylab("Item")

Code

RIbarplot(df.omit.na)

Vi har väldigt få svar i lägsta kategorierna för item abk3. Vi slår därför ihop svarskategori 0 (aldrig) och 1 (sällan) för detta item så att efterföljande analyser kan utföras.

Code

df.omit.na$abk3 <- recode(df.omit.na$abk3, "1=0;2=1;3=2;4=3;5=4", as.factor = FALSE)

3.3 Rasch-analys 1

itemnr	item
abk1	Min arbetsbelastning är rimlig.
abk2	Jag hinner med mina arbetsuppgifter inom min arbetstid.
abk3	Mitt arbete är lagom omväxlande.
abk4	Jag upplever att andras krav på mig är rimliga.
abk5	Jag kan få hjälp om min arbetsbelastning är för hög.
abk6	Mitt arbete är fritt från psykiskt påfrestande arbetsuppgifter.

Code

RIitemfitPCM2(df.omit.na, samplesize = 250, nsamples = 32, cpu = 8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
abk1	0.58	0.576	-5.515	-5.651
abk2	0.682	0.697	-3.853	-3.916
abk3	1.223	1.194	1.79	2.102
abk4	0.603	0.619	-4.924	-4.86
abk5	0.991	0.983	-0.147	-0.24
abk6	1.068	1.056	1.093	0.695

Code

RIpcmPCA(na.omit(df.omit.na))

PCA of Rasch model residuals
Eigenvalues
1.92
1.39
1.20
0.89
0.58

Code

RIresidcorr(df.omit.na, cutoff = 0.2)

	abk1	abk2	abk3	abk4	abk5
abk1
abk2	0.46
abk3	-0.34	-0.41
abk4	-0.07	-0.1	0.07
abk5	-0.22	-0.19	-0.18	-0.3
abk6	-0.28	-0.33	-0.15	-0.1	-0.28
Note:
Relative cut-off value (highlighted in red) is 0.037, which is 0.2 above the average correlation.

Code

RIloadLoc(df.omit.na)

Code

RIitemCats(df.omit.na, items = "all")

Code

# increase fig-height above as needed, if you have many items
RItargeting(df.omit.na, xlim = c(-5,5))

Code

RIitemHierarchy(df.omit.na)

Den initiala analysen visar att items abk1, abk2 och abk4 visar något låg item fit sett till rekommenderade tröskelvärden. Det finns en mycket hög residualkorrelation mellan abk1 och abk2, samt problem med oordnade trösklar för samma två items. Vi tar bort abk1 eftersom den har lägre item fit, och slår samman svarskategorierna Ibland och Sällan för abk2.

Code

# create vector with eliminated items
removed_items <- c("abk1")

# select all items except those removed
df2 <- df.omit.na %>%
  select(!any_of(removed_items)) %>% 
  mutate(abk2 = car::recode(abk2,"2=1;3=2;4=3;5=4"))

3.3.1 Analysis of response categories

Code

RIitemCats(df2, items = c("abk2","abk3"))

Avstånden mellan tröskel 1 och 2 för abk3 är så små att vi slår samman de två lägsta svarskategorierna för abk3.

Code

df2$abk3 = car::recode(df2$abk3,"1=0;2=1;3=2;4=3;5=4")
RIitemCats(df2, items = "abk3")

3.4 Rasch-analys 2

itemnr	item
abk2	Jag hinner med mina arbetsuppgifter inom min arbetstid.
abk3	Mitt arbete är lagom omväxlande.
abk4	Jag upplever att andras krav på mig är rimliga.
abk5	Jag kan få hjälp om min arbetsbelastning är för hög.
abk6	Mitt arbete är fritt från psykiskt påfrestande arbetsuppgifter.

Code

RIitemfitPCM2(df2, samplesize = 250, nsamples = 32, cpu = 8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
abk2	0.779	0.769	-2.62	-2.796
abk3	1.078	1.044	0.69	0.572
abk4	0.562	0.57	-5.673	-5.718
abk5	0.858	0.866	-1.375	-1.721
abk6	0.896	0.895	-1.455	-1.213

Code

RIpcmPCA(na.omit(df2))

PCA of Rasch model residuals
Eigenvalues
1.50
1.34
1.30
0.85
0.01

Code

RIresidcorr(df2, cutoff = 0.2)

	abk2	abk3	abk4	abk5
abk2
abk3	-0.32
abk4	0.05	0.01
abk5	-0.12	-0.26	-0.33
abk6	-0.21	-0.25	-0.14	-0.37
Note:
Relative cut-off value (highlighted in red) is 0.006, which is 0.2 above the average correlation.

Code

RIloadLoc(df2)

Code

# increase fig-height above as needed, if you have many items
RItargeting(df2)

Code

RIitemHierarchy(df2)

Code

RItif(df2)

Analysen visar att abk4 nu har ännu lägre item fit och den tas därför bort.

Code

# create vector with eliminated items
removed_items <- c("abk1", "abk4")

# select all items except those removed
df2 <- df2 %>%
  select(!any_of(removed_items))

3.5 Rasch-analys 3

itemnr	item
abk2	Jag hinner med mina arbetsuppgifter inom min arbetstid.
abk3	Mitt arbete är lagom omväxlande.
abk5	Jag kan få hjälp om min arbetsbelastning är för hög.
abk6	Mitt arbete är fritt från psykiskt påfrestande arbetsuppgifter.

Code

RIitemfitPCM2(df2, samplesize = 250, nsamples = 32, cpu = 8)

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
abk2	0.732	0.727	-3.424	-3.658
abk3	1.005	0.983	0.108	0.015
abk5	0.669	0.673	-3.947	-4.356
abk6	0.765	0.772	-3.004	-2.93

Code

RIpcmPCA(na.omit(df2))

PCA of Rasch model residuals
Eigenvalues
1.54
1.31
1.14
0.01

Code

RIresidcorr(df2, cutoff = 0.2)

	abk2	abk3	abk5
abk2
abk3	-0.26
abk5	-0.1	-0.26
abk6	-0.16	-0.22	-0.4
Note:
Relative cut-off value (highlighted in red) is -0.035, which is 0.2 above the average correlation.

Code

RIloadLoc(df2)

Code

# increase fig-height above as needed, if you have many items
#| label: fig-arbkrv-targ
RItargeting(df2)

Code

RIitemHierarchy(df2)

Code

RIpfit(df2)

3.5.1 Targeting

Code

# increase fig-height above as needed, if you have many items
RItargeting(df2)

Figur 3.1: Targeting för området Arbetsbelastning och krav

Det kvarstår smärre problem med låg item fit, men överlag fungerar denna uppsättning items acceptabelt.

3.6 Reliability

Code

RItif(df2)

Figur 3.2: Reliabilitet för området Arbetsbelastning och krav

Vi kommer senare att utforska möjligheten att slå ihop items från ‘arbetsbelastning och krav’ och ‘återhämtning’ i den explorativa analysdelen, se Sektion 12.2.

3.7 Item-parametrar

Code

RIitemparams(df2)

	Threshold 1	Threshold 2	Threshold 3	Threshold 4	Threshold 5	Item location
abk2	-2.05	0.38	0.97	2.76	NA	0.52
abk3	-0.65	-0.23	1.31	NA	NA	0.14
abk5	-1.16	0.22	0.99	1.15	1.78	0.6
abk6	-0.94	-0.03	0.36	1.20	2.67	0.65

3.8 Transformeringstabell

Code

RIscoreSE(df2, width = 50, sdx = 7)

Ordinal sum score	Logit score	Logit std.error
0	-3.501	1.603
1	-2.161	0.953
2	-1.472	0.752
3	-1.003	0.649
4	-0.639	0.588
5	-0.334	0.548
6	-0.063	0.522
7	0.188	0.506
8	0.425	0.496
9	0.656	0.494
10	0.886	0.498
11	1.121	0.511
12	1.373	0.534
13	1.660	0.574
14	2.009	0.638
15	2.473	0.744
16	3.151	0.942
17	4.000	1.305

3.8.1 Estimering av mätvärden

Code

df2$score <- RIestThetas(df2)
write.csv(df2, "scored.csv")
summary(df2$score)

   Min. 1st Qu.  Median    Mean 3rd Qu.    Max. 
-3.5007  0.4254  0.8856  0.9669  1.3734  4.0000

Code

#df2 <- read_csv("05_rec/scored.csv")

ggplot(
  data = df2,
  aes(x = score, y = 0, fill = factor(score))
  ) +
  geom_dotplot(color = "white", 
                dotsize = 1,
                binwidth = 0.12) +
   # plot mean value
  geom_point(
    aes(
      x = mean(score),
      y = 0
    ),
    size = 6,
    shape = 18,
    color = "black"
  ) +
    # errorbar has brackets at the endpoints
  geom_errorbar(
    aes(
      xmin = mean(score) - sd(score),
      xmax = mean(score) + sd(score),
      y = 0,
      width = 0.025
    ),
    color = "black"
  ) +
  coord_cartesian(xlim = c(-4,4)) +
  theme_minimal(base_family = "Lato") +
  theme_rise() +
  scale_color_viridis_d("Antal svar",
    begin = 0.2,
    aesthetics = c("fill", "color"),
    guide = "none"
  ) +
  labs(
    title = "Mätvärden",
    subtitle = "Värden längre till höger är bättre",
    caption = "Svart diamant indikerar medelvärde, strecken runt indikerar en standardavvikelse.",
    y = "Antal respondenter",
    x = "Mätvärden"
  ) +
  theme(
    #axis.text.x = element_blank(), # remove text from both axes
    axis.text.y = element_blank()
  )

3.9 Rekommenderade items

Code

itemlabels %>% 
  filter(itemnr %in% names(df2)) %>% 
  write_csv("finalItems.csv")

itemlabels %>% 
  filter(!itemnr %in% names(df2)) %>% 
  write_csv("removedItems.csv")

itemlabels %>% 
  kbl_rise(width = 50,
           options = "hover") %>% 
  row_spec(c(1,4), background = "lightpink") %>% 
  footnote(general_title = "Notera: ",
           "Borttagna item markerade med färg.")

itemnr	item
abk1	Min arbetsbelastning är rimlig.
abk2	Jag hinner med mina arbetsuppgifter inom min arbetstid.
abk3	Mitt arbete är lagom omväxlande.
abk4	Jag upplever att andras krav på mig är rimliga.
abk5	Jag kan få hjälp om min arbetsbelastning är för hög.
abk6	Mitt arbete är fritt från psykiskt påfrestande arbetsuppgifter.
Notera:
Borttagna item markerade med färg.

3.9.1 Förändringar i svarskategorier

abk3 - Aldrig+Sällan+Ibland
abk2 - Sällan+Ibland

Code

df.omit.na$abk3 <- recode(df.omit.na$abk3,"1=0;2=1;3=2;4=3;5=4",as.factor=FALSE)
df2$abk3 = car::recode(df2$abk3,"1=0;2=1;3=2;4=3")

df2$abk2 = car::recode(df2$abk2,"2=1;3=2;4=3;5=4")