Propensity Score Analysis (PSA)

https://datascienceplus.com/how-to-use-r-for-matching-samples-propensity-score/

PSA

---

pacman::p_load(knitr, wakefield, MatchIt, tableone, captioner)

0.0.0.1

library(wakefield)

0.1 create sample data and popuation data

0.1.1 sample data

set.seed(1234)
df.patients <- r_data_frame(n = 250, age(x = 30:78,   name = 'Age'),  sex(x = c("Male", "Female"),  prob = c(0.70, 0.30),  name = "Sex"))

## Warning: `tbl_df()` is deprecated as of dplyr 1.0.0.
## Please use `tibble::as_tibble()` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_warnings()` to see where this warning was generated.

df.patients$Sample <- as.factor('Patients')

0.1.2 population data

set.seed(1234)
df.population <- r_data_frame(n = 1000, 
                              age(x = 18:80, 
                                  name = 'Age'), 
                              sex(x = c("Male", "Female"), 
                                  prob = c(0.50, 0.50), 
                                  name = "Sex"))
df.population$Sample <- as.factor('Population')

0.1.3 merge data

mydata <- rbind(df.patients, df.population)

mydata$Group <- as.logical(mydata$Sample == 'Patients')
mydata$Distress <- ifelse(mydata$Sex == 'Male', age(nrow(mydata), x = 0:42, name = 'Distress'),
                                                age(nrow(mydata), x = 15:42, name = 'Distress'))

0.1.4

library(pacman)

## Warning: package 'pacman' was built under R version 4.0.3

0.2 Table 1: Comparison of unmatched samples

pacman::p_load(tableone)
table1 <- CreateTableOne(vars = c('Age', 'Sex', 'Distress'), 
                         data = mydata, 
                         factorVars = 'Sex', 
                         strata = 'Sample')
table1 <- print(table1, 
                printToggle = FALSE, 
                noSpaces = TRUE)
kable(table1[,1:3],  
      align = 'c', 
      caption = 'Table 1: Comparison of unmatched samples')

Table 1: Comparison of unmatched samples

	Patients	Population	p
n	250	1000
Age (mean (SD))	53.51 (13.86)	49.06 (17.77)	<0.001
Sex = Female (%)	87 (34.8)	513 (51.3)	<0.001
Distress (mean (SD))	23.53 (11.94)	25.44 (10.97)	0.015

0.3 matching

set.seed(1234)

match.it <- matchit(Group ~ Age + Sex, data = mydata, method="nearest", ratio=1)

a <- summary(match.it)

kable(a$nn, digits = 2, align = 'c', 
      caption = 'Table 2: Sample sizes')

Table 2: Sample sizes

	Control	Treated
All	1000	250
Matched	250	250
Unmatched	750	0
Discarded	0	0

kable(a$sum.matched[c(1,2,4)], digits = 2, align = 'c', 
      caption = 'Table 3: Summary of balance for matched data')

Table 3: Summary of balance for matched data

	Means Treated	Means Control	Mean Diff
distance	0.22	0.22	0.00
Age	53.51	53.47	0.04
SexMale	0.65	0.65	0.00
SexFemale	0.35	0.35	0.00

plot(match.it, type = 'jitter', interactive = FALSE)

0.4 save new dataset

df.match <- match.data(match.it)[1:ncol(mydata)]
rm(df.patients, df.population)

0.5 new result

pacman::p_load(tableone)
table4 <- CreateTableOne(vars = c('Age', 'Sex', 'Distress'), 
                         data = df.match, 
                         factorVars = 'Sex', 
                         strata = 'Sample')
table4 <- print(table4, 
                printToggle = FALSE, 
                noSpaces = TRUE)
kable(table4[,1:3],  
      align = 'c', 
      caption = 'Table 4: Comparison of matched samples')

Table 4: Comparison of matched samples

	Patients	Population	p
n	250	250
Age (mean (SD))	53.51 (13.86)	53.47 (13.85)	0.974
Sex = Female (%)	87 (34.8)	87 (34.8)	1.000
Distress (mean (SD))	23.53 (11.94)	23.68 (11.85)	0.884