Skip to content

Commit 805f26a

Browse files
jenniferxu1101jenniferxu1101
committed
print_effects and rounding
1 parent 5b2ba3c commit 805f26a

1 file changed

Lines changed: 109 additions & 15 deletions

File tree

‎R/est_s_t_y-methods.R‎

Lines changed: 109 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -2,29 +2,29 @@
22

33
#' @rdname est_psi
44
#' @export
5-
print.est_psi <- function(object, ...){
5+
print.est_psi <- function(object, rounding=3, ...){
66

77
if(object$simple_trunc){
88

9-
df <- data.frame(gamma=object$gamma, Estimates=object$est, Var=object$var,
10-
Lower_95CI=object$lowerCI, Upper_95CI=object$upperCI)
9+
df <- data.frame(gamma=object$gamma, Estimates=round(object$est, rounding), Var=round(object$var, rounding),
10+
Lower_95CI=round(object$lowerCI, rounding), Upper_95CI=round(object$upperCI, rounding))
1111

12-
df_R1 <- data.frame(Estimates=object$est_R1[1], Var=object$var_R1[1],
13-
Lower_95CI=object$lowerCI_R1[1], Upper_95CI=object$upperCI_R1[1])
12+
df_R1 <- data.frame(Estimates=round(object$est_R1[1], rounding), Var=round(object$var_R1[1], rounding),
13+
Lower_95CI=round(object$lowerCI_R1[1], rounding), Upper_95CI=round(object$upperCI_R1[1], rounding))
1414

15-
df_R0 <- data.frame(gamma=object$gamma, Estimates=object$est_R0, Var=object$var_R0,
16-
Lower_95CI=object$lowerCI_R0, Upper_95CI=object$upperCI_R0)
15+
df_R0 <- data.frame(gamma=object$gamma, Estimates=round(object$est_R0, rounding), Var=round(object$var_R0, rounding),
16+
Lower_95CI=round(object$lowerCI_R0, rounding), Upper_95CI=round(object$upperCI_R0, rounding))
1717

1818
}else{
1919

20-
df <- data.frame(gamma=object$gamma, Estimates=object$est_trunc, Var=object$var_trunc,
21-
Lower_95CI=object$lowerCI_trunc, Upper_95CI=object$upperCI_trunc)
20+
df <- data.frame(gamma=object$gamma, Estimates=round(object$est_trunc, rounding), Var=round(object$var_trunc, rounding),
21+
Lower_95CI=round(object$lowerCI_trunc, rounding), Upper_95CI=round(object$upperCI_trunc, rounding))
2222

23-
df_R1 <- data.frame(Estimates=object$est_trunc_R1[1], Var=object$var_trunc_R1[1],
24-
Lower_95CI=object$lowerCI_trunc_R1[1], Upper_95CI=object$upperCI_trunc_R1[1])
23+
df_R1 <- data.frame(Estimates=round(object$est_trunc_R1[1], rounding), Var=round(object$var_trunc_R1[1], rounding),
24+
Lower_95CI=round(object$lowerCI_trunc_R1[1], rounding), Upper_95CI=round(object$upperCI_trunc_R1[1], rounding))
2525

26-
df_R0 <- data.frame(gamma=object$gamma, Estimates=object$est_trunc_R0, Var=object$var_trunc_R0,
27-
Lower_95CI=object$lowerCI_trunc_R0, Upper_95CI=object$upperCI_trunc_R0)
26+
df_R0 <- data.frame(gamma=object$gamma, Estimates=round(object$est_trunc_R0, rounding), Var=round(object$var_trunc_R0, rounding),
27+
Lower_95CI=round(object$lowerCI_trunc_R0, rounding), Upper_95CI=round(object$upperCI_trunc_R0, rounding))
2828

2929
}
3030

@@ -50,8 +50,102 @@ print.est_psi <- function(object, ...){
5050

5151

5252

53-
54-
53+
#' @rdname est_psi
54+
#' @export
55+
print_effects.est_psi <- function(object_t1, object_t0, rounding=3, ...){
56+
57+
n_gamma1 <- length(object_t1$gamma)
58+
n_gamma0 <- length(object_t0$gamma)
59+
60+
## data frame for results
61+
res_out_diff <- expand.grid(gamma1=object_t1$gamma, gamma0=object_t0$gamma, Type=c("CCCE", "PPCE"))
62+
res_out_diff <- rbind(res_out_diff, data.frame(gamma1=NA, gamma0=NA, type="RTCE"))
63+
res_out_diff$Estimates <- 0
64+
res_out_diff$Var <- 0
65+
66+
## compute variance
67+
if((!is.null(object_t1$IF))&(!is.null(object_t0$IF))){
68+
scale_n <- 1 / length(object_t1$IF)
69+
}else{
70+
stop("Cannot estimate the variance of the treatment effect without influence functions for both treatment groups.")
71+
}
72+
73+
fold_idx <- split(seq_along(object_t1$fold_index_l), object_t1$fold_index_l)
74+
75+
if(!object$simple_trunc){
76+
77+
t1_IF_mat <- t(do.call(rbind, object_t1$IF_trunc))
78+
t1_IF_R0_mat <- t(do.call(rbind, object_t1$IF_trunc_R0))
79+
t1_IF_R1_mat <- t(do.call(rbind, object_t1$IF_trunc_R1))
80+
81+
res_out_diff$Estimates[which(res_out_diff$type=="RTCE")] <- round(object_t1$est_trunc_R1[1]-object_t0$est_trunc_R1[1], rounding)
82+
83+
IF_R1_diff <- t1_IF_R1_mat - object_t0$IF_trunc_R1[[1]]
84+
var_R1_temp <- vapply(fold_idx, function(id) colVars(IF_R1_diff[id, ]), numeric(n_gamma1))
85+
res_out_diff$Var[which(res_out_diff$Type=="RTCE")] <- round(rowMeans(var_R1_temp)[1]*scale_n, rounding)
86+
87+
for (g_0 in seq_along(object_t0$gamma)) {
88+
89+
IF_diff <- t1_IF_mat - object_t0$IF_trunc[[g_0]]
90+
IF_R0_diff <- t1_IF_R0_mat - object_t0$IF_trunc_R0[[g_0]]
91+
92+
var_temp <- vapply(fold_idx, function(id) colVars(IF_diff[id, ]), numeric(n_gamma1))
93+
var_R0_temp <- vapply(fold_idx, function(id) colVars(IF_R0_diff[id, ]), numeric(n_gamma1))
94+
95+
indx_CCCE <- which(res_out_diff$gamma0==object_t0$gamma[g_0]&res_out_diff$Type=="CCCE")
96+
res_out_diff$Estimates[indx_CCCE] <- round(object_t1$est_trunc-object_t0$est_trunc, rounding)
97+
res_out_diff$Var[indx_CCCE] <- round(rowMeans(var_temp)*scale_n, rounding)
98+
99+
indx_PPCE <- which(res_out_diff$gamma0==object_t0$gamma[g_0]&res_out_diff$Type=="PPCE")
100+
res_out_diff$Estimates[indx_PPCE] <- round(object_t1$est_trunc_R0-object_t0$est_trunc_R0, rounding)
101+
res_out_diff$Var[indx_PPCE] <- round(rowMeans(var_R0_temp)*scale_n, rounding)
102+
103+
}
104+
105+
106+
}else{
107+
108+
t1_IF_mat <- t(do.call(rbind, object_t1$IF))
109+
t1_IF_R0_mat <- t(do.call(rbind, object_t1$IF_R0))
110+
t1_IF_R1_mat <- t(do.call(rbind, object_t1$IF_R1))
111+
112+
res_out_diff$Estimates[which(res_out_diff$Type=="RTCE")] <- round(object_t1$est_R1[1]-object_t0$est_R1[1], rounding)
113+
114+
IF_R1_diff <- t1_IF_R1_mat - object_t0$IF_R1[[1]]
115+
var_R1_temp <- vapply(fold_idx, function(id) colVars(IF_R1_diff[id, ]), numeric(n_gamma1))
116+
res_out_diff$Var[which(res_out_diff$Type=="RTCE")] <- round(rowMeans(var_R1_temp)[1]*scale_n, rounding)
117+
118+
for (g_0 in seq_along(object_t0$gamma)) {
119+
120+
IF_diff <- t1_IF_mat - object_t0$IF[[g_0]]
121+
IF_R0_diff <- t1_IF_R0_mat - object_t0$IF_R0[[g_0]]
122+
123+
var_temp <- vapply(fold_idx, function(id) colVars(IF_diff[id, ]), numeric(n_gamma1))
124+
var_R0_temp <- vapply(fold_idx, function(id) colVars(IF_R0_diff[id, ]), numeric(n_gamma1))
125+
126+
indx_CCCE <- which(res_out_diff$gamma0==object_t0$gamma[g_0]&res_out_diff$Type=="CCCE")
127+
res_out_diff$Estimates[indx_CCCE] <- round(object_t1$est-object_t0$est, rounding)
128+
res_out_diff$Var[indx_CCCE] <- round(rowMeans(var_temp)*scale_n, rounding)
129+
130+
indx_PPCE <- which(res_out_diff$gamma0==object_t0$gamma[g_0]&res_out_diff$Type=="PPCE")
131+
res_out_diff$Estimates[indx_PPCE] <- round(object_t1$est_R0-object_t0$est_R0, rounding)
132+
res_out_diff$Var[indx_PPCE] <- round(rowMeans(var_R0_temp)*scale_n, rounding)
133+
134+
}
135+
136+
}
137+
138+
## 95% CI
139+
res_out_diff$lowerCI <- round(res_out_diff$Estimates-qnorm(0.975)*sqrt(res_out_diff$Var), rounding)
140+
res_out_diff$upperCI <- round(res_out_diff$Estimates+qnorm(0.975)*sqrt(res_out_diff$Var), rounding)
141+
142+
## output table
143+
cat("Estimation of CCCE, PPCE, RTCE. \n")
144+
cat("======================\n")
145+
print.data.frame(res_out_diff, row.names = FALSE)
146+
cat("\n")
147+
148+
}
55149

56150

57151

0 commit comments

Comments
 (0)