###
### Example: propensity score matching
###
##Load the LaLonde data
data(LaLonde)
## Estimate CBPS via logistic regression
fit <- CBPS(treat ~ age + educ + re75 + re74 + I(re75==0) + I(re74==0),
data = LaLonde, ATT = TRUE)
summary(fit)
## matching via MatchIt: one to one nearest neighbor with replacement
library(MatchIt)
m.out <- matchit(treat ~ fitted(fit), method = "nearest", data = LaLonde,
replace = TRUE)
### Example: propensity score weighting
###
## Simulation from Kang and Shafer (2007).
set.seed(123456)
n <- 500
X <- mvrnorm(n, mu = rep(0, 4), Sigma = diag(4))
prop <- 1 / (1 + exp(X[,1] - 0.5 * X[,2] + 0.25*X[,3] + 0.1 * X[,4]))
treat <- rbinom(n, 1, prop)
y <- 210 + 27.4*X[,1] + 13.7*X[,2] + 13.7*X[,3] + 13.7*X[,4] + rnorm(n)
##Estimate CBPS with a misspecificied model
X.mis <- cbind(exp(X[,1]/2), X[,2]*(1+exp(X[,1]))^(-1)+10, (X[,1]*X[,3]/25+.6)^3,
(X[,2]+X[,4]+20)^2)
fit1 <- CBPS(treat ~ X.mis, ATT = FALSE)
summary(fit1)
## Horwitz-Thompson estimate
mean(treat*y/fit1$fitted.values)
## Inverse probability weighting
sum(treat*y/fit1$fitted.values)/sum(treat/fit1$fitted.values)
rm(list=c("y","X","prop","treat","n","X.mis","fit1"))
### Example: Covariate Balancing Marginal Structural Model
###
## Simulation from Imai and Ratkovic (2013).
data1<-MSMdata(200)
attach(data1)
formulas.msm<-list(c(treat.1~X1, treat.2~X2, treat.3~X3))
msm1<-CBPS(formulas.msm,method="over",type="MSM")
#Unweighted model
lm1<-lm(y~treat.1+treat.2+treat.3)
summary(lm1)
#CBMSM weighted model
lm2<-lm(y~treat.1+treat.2+treat.3,weights=msm1$weights)
summary(lm2)
detach(data1)
### Example: Covariate Balancing Propensity Score - 3 Treatments
##
set.seed(1)
library(MASS)
X<-cbind(1,mvrnorm(1000,c(0,0,0), Sigma=matrix(c(5,.5,-.03,.5,1,-.27,-.03,-.27,1),3,3)))
beta<-matrix(rnorm(8),4,2)
prob<-cbind((1+exp(X%*%beta[,1])+exp(X%*%beta[,2]))^-1,
exp(X%*%beta[,1])*(1+exp(X%*%beta[,1])+exp(X%*%beta[,2]))^-1,
exp(X%*%beta[,2])*(1+exp(X%*%beta[,1])+exp(X%*%beta[,2]))^-1)
X<-X[,2:4]
treat.latent<-runif(1000)
treat<-ifelse(treat.latent < prob[,1], 1,
ifelse(treat.latent < (prob[,1] + prob[,2]), 2, 3))
fit3<-CBPS(treat ~ X, ATT = FALSE)
### Example: Multiple Binary Treatments Administered at the Same Time
n<-200
k<-4
set.seed(1040)
X1<-cbind(1,matrix(rnorm(n*k),ncol=k))
betas.1<-betas.2<-betas.3<-c(2,4,4,-4,3)/5
probs.1<-probs.2<-probs.3<-(1+exp(-X1 %*% betas.1))^-1
treat.1<-rbinom(n=length(probs.1),size=1,probs.1)
treat.2<-rbinom(n=length(probs.2),size=1,probs.2)
treat.3<-rbinom(n=length(probs.3),size=1,probs.3)
X1<-X1[,-1]
formulas.multi<-list(c(treat.1~X1, treat.2~X1, treat.3~X1))
multibin1<-CBPS(formulas.multi,method="over",type="MultiBin")
y<-cbind(treat.1,treat.2,treat.3) %*% c(2,2,2)+X1 %*% c(-2,8,7,6,2) + rnorm(n,sd=5)
contrast.mat<-rbind(
diag(3),
c(1,1,1),
c(1,1,-1),
c(1,-1,-1),
c(1,-1,1)
)
treat.mat<-cbind(treat.1,treat.2,treat.3)%*%t(contrast.mat)
Rsq.raw<-apply(treat.mat,2,F=function(x) summary(lm(x~X1))$r.sq)
Rsq.wt<-apply(treat.mat,2,F=function(x) summary(lm(x~X1,w=multibin1$w))$r.sq)
plot(Rsq.raw,1:7,type="n",xlim=range(cbind(Rsq.raw,Rsq.wt)),
ylab="Contrasts",xlab="R-Squared")
abline(h=c(1:7),col=gray(.5))
points(Rsq.raw,1:7,pch="O")
points(Rsq.wt,1:7,pch="X")
#Unweighted model
lm1<-lm(y~treat.1+treat.2+treat.3+X1)
summary(lm1)
#CBMSM weighted model
lm2<-lm(y~treat.1+treat.2+treat.3+X1, weights=multibin1$weights)
summary(lm2)
Run the code above in your browser using DataLab