10 Psykologisk trygghet

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 = "pt")) %>% 
  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("q0013"),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("q0013"))

names(df) <- itemlabels$itemnr

10.1 Items

Code

itemlabels %>% 
  kbl_rise(width = 45)

itemnr	item
pt1	Jag har en positiv känsla när jag kommer till jobbet.
pt2	Jag känner mig delaktig i gemenskapen på min arbetsplats.
pt3	Jag kan begå misstag utan att det hålls emot mig.
pt4	Jag kan öppet diskutera olika typer av svårigheter.
pt5	Jag blir inkluderad även om jag tycker annorlunda.
pt6	Mina ansträngningar värdesätts.
pt7	Mina idéer ges tid och uppmärksamhet.

10.2 Bakgrundsdata

Kön

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

Ålder

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

Bransch

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

Arbete hemifrån

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

10.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,"pt")

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("q0013"),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("q0013"))

names(df) <- itemlabels$itemnr

df.omit.na <- df

10.2.2 Alla svar för alla frågor

Code

RIallresp(df.omit.na)

Response category	Number of responses	Percent
Alltid	1088	33.1
Mycket ofta	1196	36.4
Ganska ofta	553	16.8
Ibland	294	9.0
Sällan	118	3.6
Aldrig	34	1.0

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)))

10.2.3 Descriptives - all items

Tile plot

Code

RItileplot(df.omit.na)

Stacked bars

Code

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

Barplots

Code

RIbarplot(df.omit.na)

Guttman heatmap

Code

RIheatmap(df.omit.na)

10.2.3.1 Fördelning av summerade svar

Code

RIrawdist(df.omit.na)

10.3 Rasch-analys 1

itemnr	item
pt1	Jag har en positiv känsla när jag kommer till jobbet.
pt2	Jag känner mig delaktig i gemenskapen på min arbetsplats.
pt3	Jag kan begå misstag utan att det hålls emot mig.
pt4	Jag kan öppet diskutera olika typer av svårigheter.
pt5	Jag blir inkluderad även om jag tycker annorlunda.
pt6	Mina ansträngningar värdesätts.
pt7	Mina idéer ges tid och uppmärksamhet.

Item fit

Code

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

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
pt1	1.192	1.117	1.606	1.165
pt2	0.866	0.872	-1.156	-1.372
pt3	1.013	1.027	0.248	0.268
pt4	0.847	0.809	-1.539	-1.966
pt5	0.63	0.614	-3.924	-4.388
pt6	0.862	0.864	-1.559	-1.415
pt7	0.811	0.799	-1.872	-2.066

PCA

Code

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

PCA of Rasch model residuals

Eigenvalues
1.89
1.60
1.09
0.96
0.77

Residual correlations

Code

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

	pt1	pt2	pt3	pt4	pt5	pt6	pt7
pt1
pt2	0.09
pt3	-0.26	-0.14
pt4	-0.27	-0.27	0.06
pt5	-0.37	-0.1	0.04	0.1
pt6	-0.18	-0.28	-0.36	-0.25	-0.18
pt7	-0.11	-0.25	-0.4	-0.28	-0.19	0.33
Note:
Relative cut-off value (highlighted in red) is 0.045, which is 0.2 above the average correlation.

1st contrast loadings

Code

RIloadLoc(df.omit.na)

Analysis of response categories

Code

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

Targeting

Code

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

Item hierarchy

Code

RIitemHierarchy(df.omit.na)

Det finns några residualkorrelationer som avviker, och item 5 är något låg i item fit. Största residualkorrelationen (med stor marginal) är mellan items 6 och 7. Eftersom item 7 har lite problem med svarskategorierna tas den bort.

Code

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

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

10.4 Rasch-analys 2

itemnr	item
pt1	Jag har en positiv känsla när jag kommer till jobbet.
pt2	Jag känner mig delaktig i gemenskapen på min arbetsplats.
pt3	Jag kan begå misstag utan att det hålls emot mig.
pt4	Jag kan öppet diskutera olika typer av svårigheter.
pt5	Jag blir inkluderad även om jag tycker annorlunda.
pt6	Mina ansträngningar värdesätts.

Item fit

Code

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

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
pt1	1.156	1.091	1.44	0.788
pt2	0.829	0.813	-1.744	-1.797
pt3	0.911	0.911	-0.896	-0.899
pt4	0.773	0.741	-2.5	-2.715
pt5	0.59	0.58	-4.434	-4.796
pt6	1.003	0.967	-0.021	-0.33

PCA

Code

RIpcmPCA(na.omit(df2))

PCA of Rasch model residuals

Eigenvalues
1.71
1.33
1.16
1.01
0.80

Residual correlations

Code

RIresidcorr(df2, cutoff = 0.2)

	pt1	pt2	pt3	pt4	pt5	pt6
pt1
pt2	0.06
pt3	-0.32	-0.23
pt4	-0.31	-0.35	-0.02
pt5	-0.4	-0.15	-0.04	0.05
pt6	-0.13	-0.24	-0.35	-0.21	-0.12
Note:
Relative cut-off value (highlighted in red) is 0.017, which is 0.2 above the average correlation.

1st contrast loadings

Code

RIloadLoc(df2)

Targeting

Code

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

Item hierarchy

Code

RIitemHierarchy(df2)

Item 5 uppvisar nu lägre item fit och även en residualkorrelation, så den tas bort.

Code

# create vector with eliminated items
removed_items <- c("pt7","pt5")

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

10.5 Rasch-analys 3

itemnr	item
pt1	Jag har en positiv känsla när jag kommer till jobbet.
pt2	Jag känner mig delaktig i gemenskapen på min arbetsplats.
pt3	Jag kan begå misstag utan att det hålls emot mig.
pt4	Jag kan öppet diskutera olika typer av svårigheter.
pt6	Mina ansträngningar värdesätts.

Item fit

Code

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

	OutfitMSQ	InfitMSQ	OutfitZSTD	InfitZSTD
pt1	0.974	0.916	-0.126	-0.595
pt2	0.751	0.732	-2.621	-2.933
pt3	0.846	0.853	-1.665	-1.416
pt4	0.755	0.716	-2.889	-3.15
pt6	0.905	0.885	-0.812	-1.231

PCA

Code

RIpcmPCA(na.omit(df2))

PCA of Rasch model residuals

Eigenvalues
1.63
1.34
1.05
0.98
0.00

Residual correlations

Code

RIresidcorr(df2, cutoff = 0.2)

	pt1	pt2	pt3	pt4	pt6
pt1
pt2	0
pt3	-0.38	-0.23
pt4	-0.35	-0.33	0.01
pt6	-0.19	-0.26	-0.34	-0.19
Note:
Relative cut-off value (highlighted in red) is -0.026, which is 0.2 above the average correlation.

1st contrast loadings

Code

RIloadLoc(df2)

Targeting

Code

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

Item hierarchy

Code

RIitemHierarchy(df2)

10.5.1 Targeting

Code

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

Figur 10.1: Targeting för området Psykologisk trygghet

Denna uppsättning items fungerar väl tillsammans.

10.6 DIF-analysis

En DIF-analys bör inte inkludera svarskategorier med för få svar. Därför har svarskategorier med färre än 50 svar antingen exkluderas eller slagits ihop med andra svarskategorier (se avsnittet om bakgrundsdata för exakt antal svar per ordinarie kategori). DIF-variablerna omkodades till att innehålla följande kategorier:

• Kön: man, kvinna
• Ålder: 30-39, 40-49, 50-59, 60+
• Bransch: kontorsarbete, ej kontorsarbete
• Hemarbete: aldrig eller sällan, en dag, minst två dagar

Koden nedan specificerar exakt hur omkodningen gick till.

Code

# Omkodning för kön
dif.kön <- recode(dif.kön,"'Annat'=NA;'Vill ej uppge'=NA")

# Omkodning för ålder
dif.ålder <- recode(dif.ålder,"'18-29'=NA")

# Omkodning för bransch
dif.bransch <- recode(dif.bransch,"'Industri'='Ej kontorsarbete';'Hotell, restaurang, service'='Ej kontorsarbete';'Handel'='Ej kontorsarbete';'Skola, utbildning'='Ej kontorsarbete';'Vård, omsorg'='Ej kontorsarbete';'Byggverksamhet'='Ej kontorsarbete';'Annat'='Ej kontorsarbete'")

#Omkodning för hemarbete
dif.hemarbete <- recode(dif.hemarbete,"'Fem dagar'='Minst två dagar';'Fyra dagar'='Minst två dagar';'Tre dagar'='Minst två dagar';'Två dagar'='Minst två dagar'")

Gender

Code

RIdifTable(df2, dif.kön)

[1] "No significant DIF found."

Age

Code

RIdifTable(df2, dif.ålder)

[1] "No significant DIF found."

Bransch

Code

RIdifTable(df2, dif.bransch)

[1] "No significant DIF found."

Hemarbete

Code

RIdifTable(df2, dif.hemarbete)

[1] "No significant DIF found."

10.7 Reliability

Code

RItif(df2, lo = -5, hi = 5)

Figur 10.2: Reliabilitet för området Psykologisk trygghet

10.8 Person fit

Code

RIpfit(df2)

10.9 Item-parametrar

Code

RIitemparams(df2)

	Threshold 1	Threshold 2	Threshold 3	Threshold 4	Threshold 5	Item location
pt1	-1.24	-0.40	0.05	1.56	4.33	0.86
pt2	-2.21	-0.61	0.52	1.38	3.33	0.48
pt3	-0.68	-0.68	0.80	1.60	3.96	1
pt4	-1.12	-0.28	0.91	1.68	3.97	1.03
pt6	-1.69	-0.33	0.72	1.49	3.81	0.8

10.10 Transformeringstabell

Code

RIscoreSE(df2, width = 50)

Ordinal sum score	Logit score	Logit std.error
0	-3.870	1.519
1	-2.650	0.900
2	-2.039	0.713
3	-1.619	0.617
4	-1.291	0.558
5	-1.017	0.520
6	-0.774	0.495
7	-0.550	0.478
8	-0.338	0.468
9	-0.130	0.463
10	0.075	0.461
11	0.282	0.462
12	0.492	0.467
13	0.708	0.473
14	0.930	0.483
15	1.163	0.496
16	1.411	0.514
17	1.681	0.538
18	1.984	0.570
19	2.333	0.609
20	2.741	0.653
21	3.208	0.698
22	3.724	0.748
24	4.000	0.781

10.10.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. 
 -1.291   1.681   2.741   2.541   4.000   4.000 

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()
  )

10.11 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(5,7), background = "lightpink") %>% 
  footnote(general_title = "Notera: ",
           "Borttagna item markerade med färg.")

itemnr	item
pt1	Jag har en positiv känsla när jag kommer till jobbet.
pt2	Jag känner mig delaktig i gemenskapen på min arbetsplats.
pt3	Jag kan begå misstag utan att det hålls emot mig.
pt4	Jag kan öppet diskutera olika typer av svårigheter.
pt5	Jag blir inkluderad även om jag tycker annorlunda.
pt6	Mina ansträngningar värdesätts.
pt7	Mina idéer ges tid och uppmärksamhet.
Notera:
Borttagna item markerade med färg.

10.11.1 Förändringar i svarskategorier