]> code.communitydata.science - ml_measurement_error_public.git/blob - simulations/example_2_binary.R
add TADA stuff
[ml_measurement_error_public.git] / simulations / example_2_binary.R
1 ### EXAMPLE 2: demonstrates how measurement error can lead to a type sign error in a covariate
2 ### Even when you have a good predictor, if it's biased against a covariate you can get the wrong sign.
3 ### Even when you include the proxy variable in the regression.
4 ### But with some ground truth and multiple imputation, you can fix it.
5
6 library(argparser)
7 library(mecor)
8 library(ggplot2)
9 library(data.table)
10 library(filelock)
11 library(arrow)
12 library(Amelia)
13 library(Zelig)
14
15 options(amelia.parallel="multicore",
16         amelia.ncpus=40)
17
18 ## SETUP:
19 ### we want to estimate g -> y and x -> y; g is observed, x is MAR
20 ### we have k -> x; g -> x; g->k; k is used to predict x via the model w.
21 ### we have k -> w; x -> w; w is observed.
22 ### for illustration, g is binary (e.g., gender==male).
23 ### A realistic scenario is that we have an NLP model predicting something like "racial harassment" in social media comments
24 ### Whether a comment is "racial harassment" depends on context, like the kind of person (i.e.,) the race of the person making the comment
25 ### e.g., a Black person saying "n-word" is less likely to be racial harassement than if a white person does it.
26 ### Say we have a language model that predicts "racial harassment," but it doesn't know the race of the writer.
27 ### Our content analyzers can see signals of the writer's race (e.g., a profile or avatar). So our "ground truth" takes this into accont.
28 ### Our goal is to predict an outcome (say that someone gets banned from the platform) as a function of whether they made a racial harassing comment and of their race. 
29
30 ### simulation:
31 #### how much power do we get from the model in the first place? (sweeping N and m)
32 #### 
33 logistic <- function(x) {1/(1+exp(-1*x))}
34
35 simulate_latent_cocause <- function(N, m, B0, Bxy, Bgy, Bkx, Bgx, seed){
36     set.seed(seed)
37
38     ## the true value of x
39
40     g <- rbinom(N, 1, 0.5)
41     k <- rnorm(N, 0, 1)
42     xprime <- Bkx*k + Bgx * g
43     x <- rbinom(N, 1, logistic(xprime - mean(xprime)))
44     w.model <- glm(x ~ k,family='binomial')
45     w <- as.integer(predict(w.model,data.frame(k=k),type='response') > 0.5)
46     ## y = B0 + B1x + e
47     y <-  Bxy * x  + Bgy * g + rnorm(N, 0, 1) + B0
48     df <- data.table(x=x,k=k,y=y,w=w,g=g)
49     if( m < N){
50         df <- df[sample(nrow(df), m), x.obs := x]
51     } else {
52         df <- df[, x.obs := x]
53     }
54
55     return(df)
56 }
57
58
59 run_simulation <-  function(N, m, B0, Bxy, Bgy, Bkx, Bgx, seed){
60     result <- list()
61     df <- simulate_latent_cocause(N, m, B0, Bxy, Bgy, Bkx, Bgx, seed)
62
63     result <- append(result, list(N=N,
64                                   m=m,
65                                   B0=B0,
66                                   Bxy=Bxy,
67                                   Bgy=Bgy,
68                                   Bkx=Bkx,
69                                   seed=seed))
70
71     accuracy <- df[,.(mean(w==x))]$V1
72     result <- append(result, list(accuracy=accuracy))
73
74     model.true <- lm(y ~ x + g, data=df)
75     true.ci.Bxy <- confint(model.true)['x',]
76     true.ci.Bgy <- confint(model.true)['g',]
77
78     result <- append(result, list(Bxy.est.true=coef(model.true)['x'],
79                                   Bgy.est.true=coef(model.true)['g'],
80                                   Bxy.ci.upper.true = true.ci.Bxy[2],
81                                   Bxy.ci.lower.true = true.ci.Bxy[1],
82                                   Bgy.ci.upper.true = true.ci.Bgy[2],
83                                   Bgy.ci.lower.true = true.ci.Bgy[1]))
84                                   
85
86     model.naive <- lm(y~w+g, data=df)
87     
88     naive.ci.Bxy <- confint(model.naive)['w',]
89     naive.ci.Bgy <- confint(model.naive)['g',]
90
91     result <- append(result, list(Bxy.est.naive=coef(model.naive)['w'],
92                                   Bgy.est.naive=coef(model.naive)['g'],
93                                   Bxy.ci.upper.naive = naive.ci.Bxy[2],
94                                   Bxy.ci.lower.naive = naive.ci.Bxy[1],
95                                   Bgy.ci.upper.naive = naive.ci.Bgy[2],
96                                   Bgy.ci.lower.naive = naive.ci.Bgy[1]))
97                                   
98
99     ## multiple imputation when k is observed
100     amelia.out.k <- amelia(df, m=200, p2s=0, idvars=c('x'),noms=c("x.obs","w","g"))
101     mod.amelia.k <- zelig(y~x.obs+g, model='ls', data=amelia.out.k$imputations, cite=FALSE)
102     coefse <- combine_coef_se(mod.amelia.k, messages=FALSE)
103
104     est.x.mi <- coefse['x.obs','Estimate']
105     est.x.se <- coefse['x.obs','Std.Error']
106     result <- append(result,
107                      list(Bxy.est.amelia.full = est.x.mi,
108                           Bxy.ci.upper.amelia.full = est.x.mi + 1.96 * est.x.se,
109                           Bxy.ci.lower.amelia.full = est.x.mi - 1.96 * est.x.se
110                           ))
111
112     est.g.mi <- coefse['g','Estimate']
113     est.g.se <- coefse['g','Std.Error']
114
115     result <- append(result,
116                      list(Bgy.est.amelia.full = est.g.mi,
117                           Bgy.ci.upper.amelia.full = est.g.mi + 1.96 * est.g.se,
118                           Bgy.ci.lower.amelia.full = est.g.mi - 1.96 * est.g.se
119                           ))
120
121     ## What if we can't observe k -- most realistic scenario. We can't include all the ML features in a model.
122     amelia.out.nok <- amelia(df, m=200, p2s=0, idvars=c("x","k"), noms=c("x.obs","w",'g'))
123     mod.amelia.nok <- zelig(y~x.obs+g, model='ls', data=amelia.out.nok$imputations, cite=FALSE)
124     coefse <- combine_coef_se(mod.amelia.nok, messages=FALSE)
125
126     est.x.mi <- coefse['x.obs','Estimate']
127     est.x.se <- coefse['x.obs','Std.Error']
128     result <- append(result,
129                      list(Bxy.est.amelia.nok = est.x.mi,
130                           Bxy.ci.upper.amelia.nok = est.x.mi + 1.96 * est.x.se,
131                           Bxy.ci.lower.amelia.nok = est.x.mi - 1.96 * est.x.se
132                           ))
133
134     est.g.mi <- coefse['g','Estimate']
135     est.g.se <- coefse['g','Std.Error']
136
137     result <- append(result,
138                      list(Bgy.est.amelia.nok = est.g.mi,
139                           Bgy.ci.upper.amelia.nok = est.g.mi + 1.96 * est.g.se,
140                           Bgy.ci.lower.amelia.nok = est.g.mi - 1.96 * est.g.se
141                           ))
142
143     return(result)
144 }
145
146 Ns <- c(100, 200, 300, 400, 500, 1000, 2500, 5000, 7500)
147 ms <- c(30, 50, 100, 200, 300, 500)
148 B0 <- 0
149 Bxy <- 1
150 Bgy <- 0.3
151 Bkx <- 3
152 Bgx <- -4
153 seeds <- 1:100
154
155 rows <- list()
156
157 for(N in Ns){
158     print(N)
159     for(m in ms){
160         if(N>m){
161             for(seed in seeds){
162                 rows <- append(rows, list(run_simulation(N, m, B0, Bxy, Bgy, Bkx, Bgx, seed)))
163             }
164         }
165     }
166 }
167
168 result <- rbindlist(rows)
169 write_feather(result, "example_2_simulation.feather")

Community Data Science Collective || Want to submit a patch?