diff --git a/NAMESPACE b/NAMESPACE index 2671e52..7a76276 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -20,7 +20,7 @@ importFrom("ggplot2", "ggplot_build", "geom_boxplot", "geom_density", "geom_tile "scale_colour_manual", "aes", "annotate", "ggtitle", "geom_rect", "scale_color_discrete", "scale_color_manual", "ggplotGrob", "guide_legend", "margin", "geom_jitter", "geom_pointrange", - "guides","xlab","ylab","element_rect","geom_errorbar") + "guides","xlab","ylab","element_rect","geom_errorbar","ggsave") importFrom("abind", "abind") importFrom("mvtnorm", "rmvnorm") importFrom("GGally", "ggpairs") @@ -28,8 +28,10 @@ importFrom("graphics", "plot") importFrom("gridExtra", "grid.arrange", "arrangeGrob") importFrom("grid", "textGrob", "gpar") importFrom("fixest", "feols") +importFrom("cowplot","plot_grid") - +export(fectHTE) +export(plotHTE) export(interFE) export(fect) S3method("fect", "default") diff --git a/R/HTE.R b/R/HTE.R new file mode 100644 index 0000000..5843ee1 --- /dev/null +++ b/R/HTE.R @@ -0,0 +1,1523 @@ +################################################################### +## Heterogeneous Effect Function +################################################################### +#a new function for HTE estimate +fectHTEonce <- function(data, + Yname, + Dname, + Xname = NULL, + Moderator, + DataType = DataType, + Nbins = Nbins, + W = NULL, # weight + group = NULL, # cohort + na.rm = FALSE, # remove missing values + index, # c(unit, time) indicators + force = "two-way", # fixed effects demeaning + r = 0, # number of factors + lambda = NULL, # mc method: regularization parameter + nlambda = 10, ## mc method: regularization parameter + CV = NULL, # cross-validation + k = 10, # times of CV + cv.prop = 0.1, ## proportion of CV counts + cv.treat = FALSE, ## cv targeting treated units + cv.nobs = 3, ## cv taking consecutive units + cv.donut = 0, ## cv mspe + criterion = "mspe", # for ife model: mspe, pc or both + binary = FALSE, # probit model + QR = FALSE, # QR or SVD for binary probit + method = "fe", # method: e for fixed effects; ife for interactive fe; mc for matrix completion + se = FALSE, # report uncertainties + vartype = "bootstrap", # bootstrap or jackknife + quantile.CI = FALSE, + nboots = 200, # number of bootstraps + alpha = 0.05, # significance level + parallel = TRUE, # parallel computing + cores = NULL, # number of cores + tol = 0.001, # tolerance level + max.iteration = 1000, + seed = NULL, # set seed + min.T0 = NULL, # minimum T0 + max.missing = NULL, # maximum missing + proportion = 0.3, # use to fit the f test and equivalence test + pre.periods = NULL, # fit test period + f.threshold = 0.5, # equiv + tost.threshold = NULL, # equiv + knots = NULL, + degree = 2, # wald = FALSE, # fit test + sfe = NULL, + cfe = NULL, + balance.period = NULL, # the pre and post periods for balanced samples + fill.missing = FALSE, # whether to balance missing observations + placeboTest = FALSE, # placebo test + placebo.period = NULL, # placebo test period + carryoverTest = FALSE, # carry-over test + carryover.period = NULL, # carry-over period + carryover.rm = NULL, + loo = FALSE, # leave one period out placebo + permute = FALSE, ## permutation test + m = 2, ## block length + normalize = FALSE, # accelerate option + HTE.enp.seq = NULL #parameter used in loess fit estimation +) +{ + out.null<-list( + method = NULL, + Y.ct = NULL, + Y.ct.full = NULL, + D = NULL, + Y = NULL, + X = NULL, + eff = NULL, + I = NULL, + II = NULL, + att.avg = NA, + att.avg.boot = NULL, + att.avg.unit = NA, + est.avg = c(NA,NA,NA,NA), + ## supporting + force = NULL, + T = NULL, + N = NULL, + Ntr = NULL, + Nco = NULL, + tr = NULL, + co = NULL, + p = NULL, + r.cv = NULL, + IC = NULL, + beta = NULL, + est = NULL, + mu = NULL, + niter = NULL, + validX = NULL, + validF = NULL, + time = NULL, + att = NULL, + count = NULL, + eff.calendar = NULL, + N.calendar = NULL, + eff.calendar.fit = NULL, + calendar.enp = NULL, + eff.pre = NULL, + eff.pre.equiv = NULL, + pre.sd = NULL, + eff.HTE = NULL, + Val.HTE = NULL, + N.HTE = NULL, + Ntr.HTE = NULL, + eff.HTE.fit = NULL, + HTE.enp = NULL, + bootVal = NULL, + HTEcoef = NULL, + KWtest = NULL + # time.HTE = time.HTE.on, + # att.HTE = att.HTE.on, + # count.HTE = count.HTE.on + ) + HTEvalue = data[,Moderator] + + #split the sample according to the value of moderator variable + data_list = list() + if(DataType == "discrete"){ #discrete variable + HTEuni = unique(as.vector(HTEvalue)) + HTEuni <- sort(HTEuni) + Val.HTE = HTEuni + for(i in c(1:length(HTEuni))){ + temp_index = which(data[,Moderator] == HTEuni[i]) + temp_data = data[temp_index,] + data_list[[i]] = temp_data + } + } + if(DataType == "continuous"){ #continuous variable + nbins = Nbins + Val.HTE = rep(NA,nbins) + quan = 1/nbins + HTEquantile = quantile(HTEvalue,seq(quan,1,quan)) + + for(i in c(1:nbins)){ + if (i == 1){ + temp_index = which((data[,Moderator] < HTEquantile[i])) + } + else if (i == nbins){ + temp_index = which((data[,Moderator] >= HTEquantile[i - 1])) + } + else { + temp_index = which((data[,Moderator] >= HTEquantile[i - 1]) & (data[,Moderator] < HTEquantile[i])) + } + temp_data = data[temp_index,] + data_list[[i]] = temp_data + Val.HTE[i] = quan * i + } + } + out = list() + kwframe = data.frame() + id <- index[1] + time <- index[2] + for ( i in c(1:length(data_list))){ + temp_data <- data_list[[i]] + temp_data <- temp_data[order(temp_data[,id],temp_data[,time]),] + temp_Xname <- Xname + stable_var<- c() + if (length(Xname > 0)){ + for (j in 1:length(Xname)){ + if (sum(tapply(temp_data[, Xname[j]], temp_data[,id], var), na.rm = TRUE) == 0){ #deal with the situation that HTE var is unit-invariant in subsample + stable_var <- c(stable_var, j) + } + } + if (length(stable_var) > 0){ + temp_Xname <- temp_Xname[-stable_var] + } + } + temp_out <- try(fect(data = temp_data, + Y = Yname, + D = Dname, + X = temp_Xname, + W = W, + group = group, + na.rm = na.rm, + index = index, + force = force, + r = r, + lambda = lambda, + nlambda = nlambda, + CV = CV, + k = k, + cv.prop = cv.prop, + cv.treat = cv.treat, + cv.nobs = cv.nobs, + cv.donut = cv.donut, + criterion = criterion, + binary = binary, + QR = QR, + method = method, + se = FALSE, #bootstrap process has been employed in the part above + vartype = vartype, + quantile.CI = quantile.CI, + nboots = nboots, + alpha = alpha, + parallel = parallel, + cores = cores, + tol = tol, + max.iteration = max.iteration, + seed = seed, + min.T0 = min.T0, + max.missing = max.missing, + proportion = proportion, + pre.periods = pre.periods, + f.threshold = f.threshold, + tost.threshold = tost.threshold, + knots = knots, + degree = degree, + sfe = sfe, + cfe = cfe, + balance.period = balance.period, + fill.missing = fill.missing, + placeboTest = placeboTest, + placebo.period = placebo.period, + carryoverTest = carryoverTest, + carryover.period = carryover.period, + carryover.rm = carryover.rm, + loo = loo, + permute = permute, + m = m, + normalize = normalize, + Moderator = NULL, + HTE.enp.seq = HTE.enp.seq)) + if (class(temp_out) == 'try-error'){ + temp_out = out.null + } + Ntr.HTE = sum(temp_data[,Dname], rm.na = TRUE) + N.HTE = dim(temp_data)[1] + out[[i]] = temp_out + out[[i]]$NHTE = N.HTE + out[[i]]$NtrHTE = Ntr.HTE + out[[i]]$ValHTE = Val.HTE[i] + } + return(out) +} + +fectHTEeffonce <- function(eff, HTEvalue, DataType, Nbins, D){ + D.missing <- D + D.missing[which(D == 0)] <- NA + out = list() + if(DataType == "discrete"){ #discrete moderator variable + HTEuni = unique(as.vector(HTEvalue)) + HTEuni <- sort(HTEuni) + Val.HTE = HTEuni + att.avg.HTE <- rep(NA,length(HTEuni)) + N.HTE = rep(0,length(HTEuni)) + Ntr.HTE = rep(0,length(HTEuni)) + for(i in 1:length(HTEuni)){ + INDEX <- D.missing + INDEX[which(HTEvalue != HTEuni[i])] <- NA + att.avg.HTE[i] = mean(INDEX * eff, na.rm = TRUE) + N.HTE[i] = length(which(HTEvalue == HTEuni[i])) + Ntr.HTE[i] = length(INDEX) - length(is.na(INDEX)) + out[[i]] = list() + out[[i]]$NHTE = N.HTE[i] + out[[i]]$NtrHTE = Ntr.HTE[i] + out[[i]]$att.avg = att.avg.HTE[i] + out[[i]]$ValHTE = Val.HTE[i] + } + } + else if (DataType == "continuous"){ #continuous variable + nbins = Nbins + Val.HTE = rep(NA,nbins) + quan = 1/nbins + HTEquantile = quantile(HTEvalue,seq(quan,1,quan)) + att.avg.HTE <- rep(NA,nbins) + N.HTE = rep(0,nbins) + Ntr.HTE = rep(0,nbins) + for(i in c(1:nbins)){ + INDEX <- D.missing + if (i == 1){ + INDEX[which(HTEvalue >= HTEquantile[i])] <- NA + N.HTE[i] = length(which(HTEvalue < HTEquantile[i])) + } + else if (i == nbins){ + INDEX[which(HTEvalue < HTEquantile[i - 1])] <- NA + N.HTE[i] = length(which(HTEvalue >= HTEquantile[i - 1])) + } + else { + INDEX[which((HTEvalue >= HTEquantile[i]) | (HTEvalue < HTEquantile[i - 1]))] <- NA + N.HTE[i] = length(which((HTEvalue >= HTEquantile[i - 1]) & (HTEvalue < HTEquantile[i]) )) + } + att.avg.HTE[i] <- mean(INDEX * eff, na.rm = TRUE) + Val.HTE[i] = quan * i + Ntr.HTE[i] = sum(INDEX,na.rm = TRUE) + out[[i]] = list() + out[[i]]$NHTE = N.HTE[i] + out[[i]]$NtrHTE = Ntr.HTE[i] + out[[i]]$att.avg = att.avg.HTE[i] + out[[i]]$ValHTE = Val.HTE[i] + } + } + return(out) +} +fectHTE <- function(data, # a data frame (long-form) + Yname, # outcome + Dname, # treatment + Xname = NULL, # time-varying covariates + W = NULL, # weight + group = NULL, # cohort + na.rm = FALSE, # remove missing values + index, # c(unit, time) indicators + force = "two-way", # fixed effects demeaning + r = 0, # number of factors + lambda = NULL, # mc method: regularization parameter + nlambda = 10, ## mc method: regularization parameter + CV = NULL, # cross-validation + k = 10, # times of CV + cv.prop = 0.1, ## proportion of CV counts + cv.treat = FALSE, ## cv targeting treated units + cv.nobs = 3, ## cv taking consecutive units + cv.donut = 0, ## cv mspe + criterion = "mspe", # for ife model: mspe, pc or both + binary = FALSE, # probit model + QR = FALSE, # QR or SVD for binary probit + method = "fe", # method: e for fixed effects; ife for interactive fe; mc for matrix completion + se = FALSE, # report uncertainties + vartype = "bootstrap", # bootstrap or jackknife + quantile.CI = FALSE, + nboots = 200, # number of bootstraps + alpha = 0.05, # significance level + parallel = TRUE, # parallel computing + cores = NULL, # number of cores + tol = 0.001, # tolerance level + max.iteration = 1000, + seed = NULL, # set seed + min.T0 = NULL, # minimum T0 + max.missing = NULL, # maximum missing + proportion = 0.3, # use to fit the f test and equivalence test + pre.periods = NULL, # fit test period + f.threshold = 0.5, # equiv + tost.threshold = NULL, # equiv + knots = NULL, + degree = 2, # wald = FALSE, # fit test + sfe = NULL, + cfe = NULL, + balance.period = NULL, # the pre and post periods for balanced samples + fill.missing = FALSE, # whether to balance missing observations + placeboTest = FALSE, # placebo test + placebo.period = NULL, # placebo test period + carryoverTest = FALSE, # carry-over test + carryover.period = NULL, # carry-over period + carryover.rm = NULL, + loo = FALSE, # leave one period out placebo + permute = FALSE, ## permutation test + m = 2, ## block length + normalize = FALSE, # accelerate option + Moderator = NULL, #the variable needs heterogeneity estimation + DataType = "discrete", #data type of moderator + Nbins = NULL, #number of bins + HTE.enp.seq = NULL #parameter used in loess fit estimation +) { + + #prepare frequently used variables + # varnames <- all.vars(formula) + # Yname <- varnames[1] + # Dname <- varnames[2] + out.null<-list( + method = NULL, + Y.ct = NULL, + Y.ct.full = NULL, + D = NULL, + Y = NULL, + X = NULL, + eff = NULL, + I = NULL, + II = NULL, + att.avg = NA, + att.avg.boot = NULL, + att.avg.unit = NA, + est.avg = c(NA,NA,NA,NA), + ## supporting + force = NULL, + T = NULL, + N = NULL, + Ntr = NULL, + Nco = NULL, + tr = NULL, + co = NULL, + p = NULL, + r.cv = NULL, + IC = NULL, + beta = NULL, + est = NULL, + mu = NULL, + niter = NULL, + validX = NULL, + validF = NULL, + time = NULL, + att = NULL, + count = NULL, + eff.calendar = NULL, + N.calendar = NULL, + eff.calendar.fit = NULL, + calendar.enp = NULL, + eff.pre = NULL, + eff.pre.equiv = NULL, + pre.sd = NULL, + eff.HTE = NULL, + Val.HTE = NULL, + N.HTE = NULL, + eff.HTE.fit = NULL, + HTE.enp = NULL, + bootVal = NULL, + HTEcoef = NULL, + KWtest = NULL + # time.HTE = time.HTE.on, + # att.HTE = att.HTE.on, + # count.HTE = count.HTE.on + ) + + # if(DataType == "continuous"){ + # mode <- 'continuous' + # } + # if(DataType == "discrete"){ + # mode <- 'discrete' + # } + # if (length(varnames) > 2) { + # Xname <- varnames[3:length(varnames)] + # } else { + # Xname <- NULL + # } + + + if((!Moderator %in% Xname) | (!Moderator %in% colnames(data))){ + stop("Moderator not in X variables or data") + } + + id = index[1] + time = index[2] + data <- data[order(data[,id], data[,time]),] + TT <- length(unique(data[,time])) + N <- length(unique(data[,id])) + D <- matrix(data[, Dname], TT, N) + Y <- matrix(data[, Yname], TT, N) + p <- length(Xname) + X <- array(0, dim = c(TT, N, p)) + id.list <- matrix(data[,id], TT, N)[1,] + time.list <- matrix(data[,time], TT, N)[,1] + if (p > 0) { + for (i in 1:p) { + X[,,i] <- matrix(data[, Xname[i]], TT, N) + } + } + #mode judgement + if (DataType == "continuous"){ #continuous moderator + #uncertainity judgement + if (se == FALSE){ + result <- fectHTEonce(data = data,Yname = Yname,Dname = Dname,Xname = Xname,Moderator = Moderator, DataType = DataType, Nbins = Nbins, index = index, r = r, force = force, CV = CV) + return(result) + } + else { + #generate index of bootstrap + nbins = Nbins + boot.index <- array(0,dim = c(N,nboots)) + boot.att <- array(NA,dim = c(nbins,nboots)) + sum.D <- colSums(D) + id.tr <- which(sum.D>0) + id.co <- which(sum.D==0) + Nco <- length(id.co) + Ntr <- length(id.tr) + I <- matrix(1, TT, N) + I[is.nan(Y)] <- 0 + + out = fectHTEonce(data = data,Yname = Yname,Dname = Dname,Xname = Xname,Moderator = Moderator,DataType = DataType, Nbins = Nbins, index = index, r = r, force = force, CV = CV) + + #initialize the att.boot.list to store the data of att + att.boot.list = list() + time.list <- list() + for(i in 1:length(out)){ + time.list[[i]] = out[[i]]$time + att.boot.list[[i]] = matrix(NA,length(time.list[[i]]),nboots) + } + + for(i in 1:nboots){ + repeat { + fake.co <- sample(id.co,Nco, replace=TRUE) + if (sum(apply(as.matrix(I[,fake.co]), 1, sum) >= 1) == TT) { + break + } + } + # fake.co <- sample(id.co,Nco, replace=TRUE) + repeat { + fake.tr <- sample(id.tr,Ntr, replace=TRUE) + if (sum(apply(as.matrix(I[,fake.tr]), 1, sum) >= 1) == TT) { + break + } + } + # fake.tr <- sample(id.tr,Ntr, replace=TRUE) + fake.index = c(fake.co,fake.tr) + boot.index[,i] = fake.index + temp.index = c() + temp.id = c() + for (j in 1:length(fake.index)){ + temp.index.slice = ((fake.index[j] - 1)*TT + 1):(fake.index[j]*TT) + temp.id.slice = rep(j,TT) + temp.index = c(temp.index,temp.index.slice) + temp.id = c(temp.id, temp.id.slice) + } + temp.data = data[temp.index,] + temp.data[[id]] = temp.id + temp_result = fectHTEonce( data = temp.data,Yname = Yname,Dname = Dname,Xname = Xname,Moderator = Moderator, DataType = DataType, Nbins = Nbins, index = index, r = r, force = force, CV = CV) + for (k in 1:nbins){ + boot.att[k,i] = temp_result[[k]]$att.avg + att.boot.list[[k]][,i] = temp_result[[k]]$att[match(time.list[[k]],temp_result[[k]]$time)] + } + } + + for (j in 1:nbins){ + temp.boot.rm <- which(is.na(boot.att[j,])) + temp.avg.att.boot <- boot.att[j,] + temp.att.boot <- att.boot.list[[j]] + if(length(temp.boot.rm) > 0){ + temp.avg.att.boot <- boot.att[j,-temp.boot.rm] + temp.att.boot <- att.boot.list[[j]][,-temp.boot.rm] + } + temp.se.avg = sd(temp.avg.att.boot, na.rm = TRUE) + temp.att.avg = out[[j]]$att.avg + temp.se.att <- apply(temp.att.boot, 1, function(vec) sd(vec, na.rm=TRUE)) + temp.att = out[[j]]$att + if(quantile.CI == FALSE){ + temp.CI.avg <- c(temp.att.avg - temp.se.avg * qnorm(1-alpha/2), temp.att.avg + temp.se.avg * qnorm(1-alpha/2)) + temp.pvalue.avg <- (1-pnorm(abs(temp.att.avg/temp.se.avg)))*2 + + temp.CI.att <- cbind(temp.att - temp.se.att * qnorm(1-alpha/2), temp.att + temp.att.avg * qnorm(1-alpha/2)) + temp.pvalue.att <- (1-pnorm(abs(temp.att/temp.se.att)))*2 + } + else{ + temp.CI.avg <- quantile(temp.avg.att.boot,c(alpha/2,1-alpha/2), na.rm=TRUE) + pvalue.avg <- get.pvalue(temp.avg.att.boot) + + temp.CI.att <- t(apply(temp.att.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + pvalue.att <- apply(temp.att.boot, 1, get.pvalue) + } + temp.est.avg <- t(as.matrix(c(temp.att.avg, temp.se.avg, temp.CI.avg, temp.pvalue.avg))) + colnames(temp.est.avg) <- c("ATT.avg", "S.E.", "CI.lower", "CI.upper", "p.value") + + temp.est.att <- cbind(temp.att, temp.se.att, temp.CI.att, temp.pvalue.att, out[[j]]$count) + colnames(temp.est.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper","p.value", "count") + rownames(temp.est.att) <- out[[j]]$time + + out[[j]]$est.avg = temp.est.avg + out[[j]]$est.att = temp.est.att + } + return(out) + } + } + else if (DataType == "discrete"){ #discrete moderator + #uncertainity judgement + if (se == FALSE){ + result <- fectHTEonce(data = data,Yname = Yname, Dname= Dname,Xname = Xname,Moderator = Moderator, DataType = DataType, Nbins = Nbins, index = index, r = r, force = force, CV = CV) + return(result) + } + else { + #generate index of bootstrap + HTEvalue = data[,Moderator] + HTEuni = unique(as.vector(HTEvalue)) + nbins = length(HTEuni) + boot.index <- array(0,dim = c(N,nboots)) + boot.att <- array(NA,dim = c(nbins,nboots)) + sum.D <- colSums(D) + id.tr <- which(sum.D>0) + id.co <- which(sum.D==0) + Nco <- length(id.co) + Ntr <- length(id.tr) + I <- matrix(1, TT, N) + I[is.nan(Y)] <- 0 + + out = fectHTEonce(data = data,Yname = Yname, Dname = Dname, Xname = Xname,Moderator = Moderator,DataType = DataType, Nbins = Nbins, index = index, r = r, force = force, CV = CV) + + #initialize the att.boot.list to store the data of att + att.boot.list = list() + time.list <- list() + for(i in 1:length(out)){ + time.list[[i]] = out[[i]]$time + att.boot.list[[i]] = matrix(NA,length(time.list[[i]]),nboots) + } + + for(i in 1:nboots){ + repeat { + fake.co <- sample(id.co, Nco, replace=TRUE) + if (sum(apply(as.matrix(I[,fake.co]), 1, sum) >= 1) == TT) { + break + } + } + # fake.co <- sample(id.co,Nco, replace=TRUE) + repeat { + fake.tr <- sample(id.tr,Ntr, replace=TRUE) + if (sum(apply(as.matrix(I[,fake.tr]), 1, sum) >= 1) == TT) { + break + } + } + # fake.tr <- sample(id.tr,Ntr, replace=TRUE) + fake.index = c(fake.co,fake.tr) + boot.index[,i] = fake.index + temp.index = c() + temp.id = c() + for (j in 1:length(fake.index)){ + temp.index.slice = ((fake.index[j] - 1)*TT + 1):(fake.index[j]*TT) + temp.id.slice = rep(j,TT) + temp.index = c(temp.index,temp.index.slice) + temp.id = c(temp.id, temp.id.slice) + } + temp.data = data[temp.index,] + temp.data[[id]] = temp.id + temp_result = fectHTEonce( data = temp.data,Yname = Yname,Dname = Dname,Xname = Xname,Moderator = Moderator, DataType = DataType, Nbins = Nbins, index = index, r = r, force = force, CV = CV) + for (k in 1:nbins){ + boot.att[k,i] = temp_result[[k]]$att.avg + att.boot.list[[k]][,i] = temp_result[[k]]$att[match(time.list[[k]],temp_result[[k]]$time)] + } + } + + for (j in 1:nbins){ + temp.boot.rm <- which(is.na(boot.att[j,])) + temp.avg.att.boot <- boot.att[j,] + temp.att.boot <- att.boot.list[[j]] + if(length(temp.boot.rm) > 0){ + temp.avg.att.boot <- boot.att[j,-temp.boot.rm] + temp.att.boot <- att.boot.list[[j]][,-temp.boot.rm] + } + temp.se.avg = sd(temp.avg.att.boot, na.rm = TRUE) + temp.att.avg = out[[j]]$att.avg + temp.se.att <- apply(temp.att.boot, 1, function(vec) sd(vec, na.rm=TRUE)) + temp.att = out[[j]]$att + if(quantile.CI == FALSE){ + temp.CI.avg <- c(temp.att.avg - temp.se.avg * qnorm(1-alpha/2), temp.att.avg + temp.se.avg * qnorm(1-alpha/2)) + temp.pvalue.avg <- (1-pnorm(abs(temp.att.avg/temp.se.avg)))*2 + + temp.CI.att <- cbind(temp.att - temp.se.att * qnorm(1-alpha/2), temp.att + temp.att.avg * qnorm(1-alpha/2)) + temp.pvalue.att <- (1-pnorm(abs(temp.att/temp.se.att)))*2 + } + else{ + temp.CI.avg <- quantile(temp.avg.att.boot,c(alpha/2,1-alpha/2), na.rm=TRUE) + pvalue.avg <- get.pvalue(temp.avg.att.boot) + + temp.CI.att <- t(apply(temp.att.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + pvalue.att <- apply(temp.att.boot, 1, get.pvalue) + } + temp.est.avg <- t(as.matrix(c(temp.att.avg, temp.se.avg, temp.CI.avg, temp.pvalue.avg))) + colnames(temp.est.avg) <- c("ATT.avg", "S.E.", "CI.lower", "CI.upper", "p.value") + + temp.est.att <- cbind(temp.att, temp.se.att, temp.CI.att, temp.pvalue.att, out[[j]]$count) + colnames(temp.est.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper","p.value", "count") + rownames(temp.est.att) <- out[[j]]$time + + out[[j]]$est.avg = temp.est.avg + out[[j]]$est.att = temp.est.att + } + return(out) + } + } + + +} + + +testHTE <- function(out){ + kwframe = data.frame() + for(i in 1:length(out)){ + if(! is.null(out[[i]]$att.avg.boot)){ + temp_dataframe = data.frame(val = c(out[[i]]$att.avg.boot),group = rep(i,length(out[[i]]$att.avg.boot))) + kwframe = rbind(kwframe,temp_dataframe) + } + } + kwtest = NULL + aovtest = NULL + if (! is.null(kwframe)){ + kwtest = list(kruskal.test(val~group,data = kwframe)) + aovtest = list(aov(val~group,data = kwframe)) + } + result = list(kwtest = kwtest,aovtest = aovtest) + return(result) +} + + + + + + +plotHTE <- function(x, + version = "whole", # whole, seperate + mode = "discrete", # discrete, continuous + type = 'avg', # avg, dynamic + loo = FALSE, + highlight = NULL, ## for carryover test and placebo test + plot.ci = "0.95", ## "0.9", "0.95", "none" + show.points = NULL, + show.group = NULL, + bound = NULL, # "none", "min", "equiv", "both" + vis = NULL, + count = TRUE, + proportion = 0.3, # control the xlim + pre.periods = NULL, # for testing + f.threshold = NULL, # equiv f + tost.threshold = NULL, # pre-trend placebo carryover + effect.bound.ratio = FALSE, + stats = NULL, ## "none", "F.p", "F.equiv.p", "placebo.p", "carryover.p", "equiv.p" + stats.labs = NULL, + raw = "none", ## "none", "band", "all" + main = NULL, + xlim = NULL, + ylim = NULL, + xlab = NULL, + ylab = NULL, + gridOff = FALSE, + legendOff = FALSE, + legend.pos = NULL, + legend.nrow = NULL, + legend.labs = NULL, + stats.pos = NULL, + theme.bw = TRUE, + nfactors = NULL, + include.FE = TRUE, + id = NULL, + cex.main = NULL, + cex.main.sub = NULL, + cex.axis = NULL, + cex.lab = NULL, + cex.legend = NULL, + cex.text = NULL, + axis.adjust = FALSE, + axis.lab = "both", + axis.lab.gap = c(0, 0), + shade.post = FALSE, + start0 = FALSE, + return.test = FALSE, + balance = NULL, + weight = NULL, + save_path = NULL + ){ + # stats <- "none" + # # names for all statistics + # if (!("none" %in% stats)) { + # if (is.null(stats.labs)==FALSE) { + # if (length(stats.labs)!=length(stats)) { + # stop("\"stats.lab\" should have the same length as \"stats\".") + # } + # } + # else { + # stats.labs <- rep(NA, length(stats)) + # for (i in 1:length(stats)) { + # if (stats[i] == "F.p") { + # stats.labs[i] <- "F test p-value" + # } + # if (stats[i] == "F.equiv.p") { + # stats.labs[i] <- "F equivalence test p-value" + # } + # if (stats[i] == "F.stat") { + # stats.labs[i] <- "F statistics" + # } + # if (stats[i] == "placebo.p") { + # stats.labs[i] <- "Placebo test p-value" + # } + # if (stats[i] == "carryover.p") { + # stats.labs[i] <- "Carryover effect test p-value" + # } + # if (stats[i] == "equiv.p") { + # if(placeboTest){ + # stats.labs[i] <- "Placebo equivalence test p-value" + # } + # else if(carryoverTest){ + # stats.labs[i] <- "Carryover effect equivalence test p-value" + # } + # else{ + # stats.labs[i] <- "Equivalence test p-value" + # } + # } + # } + # } + # } + # + # titles; xlim and ylim + ytitle <- NULL + bound.old <- bound + maintext <- "ATT by Moderator" + ytitle <- paste("Effect on Dependent Variable") + #### font size + ## title + if (is.null(cex.main)==FALSE) { + if (is.numeric(cex.main)==FALSE) { + stop("\"cex.main\" is not numeric.") + } + cex.main <- 16 * cex.main + } else { + cex.main <- 16 + } + ## subtitle + if (is.null(cex.main.sub)==FALSE) { + if (is.numeric(cex.main.sub)==FALSE) { + stop("\"cex.main.sub\" is not numeric.") + } + cex.main.sub <- 16 * cex.main.sub + } else { + cex.main.sub <- 16 + } + ## axis label + if (is.null(cex.lab)==FALSE) { + if (is.numeric(cex.lab)==FALSE) { + stop("\"cex.lab\" is not numeric.") + } + cex.lab <- 15 * cex.lab + } else { + cex.lab <- 15 + } + ## axis number + if (is.null(cex.axis)==FALSE) { + if (is.numeric(cex.axis)==FALSE) { + stop("\"cex.axis\" is not numeric.") + } + cex.axis <- 15 * cex.axis + } else { + cex.axis <- 15 + } + ## legend + if (is.null(cex.legend)==FALSE) { + if (is.numeric(cex.legend)==FALSE) { + stop("\"cex.legend\" is not numeric.") + } + cex.legend <- 15 * cex.legend + } else { + cex.legend <- 15 + } + ## text + if (is.null(cex.text)==FALSE) { + if (is.numeric(cex.text)==FALSE) { + stop("\"cex.text\" is not numeric.") + } + cex.text <- 5 * cex.text + } else { + cex.text <- 5 + } + + ## text label position + if (!is.null(stats.pos)) { + if (length(stats.pos) != 2) { + stop(" \"stats.pos\" must be of length 2. ") + } + } + if(type == "avg" & version == 'seperate'){ + CI <- NULL #decide if we need plot uncertainties + for(i in 1:length(x)){ + if ("est.avg" %in% names(x[[i]])){ + if(sum(is.na(x[[i]]$est.avg)) != 4){ + CI <- TRUE + } + } + } + if (is.null(CI)) { + CI <- FALSE + } + if(plot.ci=="none"){ + CI <- FALSE + } + ## axes labels + if (is.null(xlab) == TRUE) { + xlab <- "Moderator" + } else if (xlab == "") { + xlab <- NULL + } + + if (is.null(ylab) == TRUE) { + ylab <- ytitle + } else if (ylab == "") { + ylab <- NULL + } + + ## y=0 line type + lcolor <- "white" + lwidth <- 2 + if (theme.bw == TRUE) { + lcolor <- "#AAAAAA70" + lwidth <- 1.5 + } + + if (CI == FALSE) { + message("Uncertainty estimates not available.\n") + YVAR = rep(NA,length(x)) + XVAR = rep(NA,length(x)) + for (i in 1:length(x)){ + YVAR[i] = x[[i]]$att.avg + XVAR[i] = x[[i]]$ValHTE + } + data.toplot.main <- cbind.data.frame(YVAR,XVAR) + + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } + else { + rect.length <- (max(c(YVAR), na.rm = TRUE) - min(c(YVAR), na.rm = TRUE))/2 + rect.min <- min(c(YVAR), na.rm = TRUE) - rect.length + } + } + else { + YVAR = rep(NA,length(x)) + XVAR = rep(NA,length(x)) + YMIN = rep(NA,length(x)) + YMAX = rep(NA,length(x)) + for (i in 1:length(x)){ + YVAR[i] = x[[i]]$est.avg[1] + YMIN[i] = x[[i]]$est.avg[3] + YMAX[i] = x[[i]]$est.avg[4] + XVAR[i] = x[[i]]$ValHTE + } + data.toplot.main <- cbind.data.frame(YVAR,YMIN,YMAX,XVAR) + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YMAX), na.rm = TRUE) - min(c(YMIN), na.rm = TRUE))/2 + rect.min <- min(c(YMIN), na.rm = TRUE) - rect.length + } + } + +p <- ggplot(data.toplot.main) + +## xlab and ylab +p <- p + xlab(xlab) + ylab(ylab) +if(x[[1]]$DataType == "continuous"){ + x_labels = rep("",length(XVAR)) + for(i in 1:length(XVAR)){ + if (i == 1){ + x_labels[i] = paste("0%-",round(100*XVAR[i],1),"%") + } + else{ + x_labels[i] = paste(round(100*XVAR[i-1],1),"%-",round(100*XVAR[i],1),"%") + } + + } + p <- p + scale_x_continuous(breaks = XVAR, labels = x_labels) +} +## theme +if (theme.bw == TRUE) { + p <- p + theme_bw() +} + +## grid +if (gridOff == TRUE) { + p <- p + theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) +} + +# horizontal 0 line +#p <- p + geom_hline(yintercept = 0, colour = lcolor,size = lwidth) + + +if(CI==FALSE){ + #p <- p + geom_point(aes(x=XVAR,y=YVAR,color='gray50',fill='gray50',alpha=1,size=1.2)) + p <- p + geom_point(aes(x=XVAR,y=YVAR),color='gray50',fill='gray50',alpha=1) +} else { + #p <- p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX,color='gray50',fill='gray50',alpha=1,size=0.6)) + p <- p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX),color='gray50',fill='gray50',alpha=1) +} +if(count==TRUE){ + NcoCOUNT = rep(NA,length(x)) + NtrCOUNT = rep(NA,length(x)) + NCOUNT = rep(NA,length(x)) + for (i in 1:length(x)){ + NtrCOUNT[i] = x[[i]]$NtrHTE + NcoCOUNT[i] = x[[i]]$NHTE - NtrCOUNT[i] + NCOUNT[i] = x[[i]]$NHTE + } + T.start <- c() + T.end <- c() + ymin <- c() + ymaxco <- c() + ymaxtr <- c() + T.gap <- (max(XVAR)-min(XVAR))/length(XVAR) + for(i in c(1:length(XVAR))){ + T.start <- c(T.start,XVAR[i]-0.25*T.gap) + T.end <- c(T.end,XVAR[i]+0.25*T.gap) + ymin <- c(ymin, rect.min) + ymaxco <- c(ymaxco, rect.min+rect.length*NcoCOUNT[i]/max(NCOUNT)) + ymaxtr <- c(ymaxtr, rect.min+rect.length*NCOUNT[i]/max(NCOUNT)) + } + data.toplotco <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymin, + ymax=ymaxco) + data.toplottr <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymaxco, + ymax=ymaxtr) + max.count.pos <- mean(XVAR[which.max(NCOUNT)]) + p <- p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplotco,fill='gray50',alpha=0.3,size=0.3,color='black') + p <- p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplottr,fill='red',alpha=0.3,size=0.3,color='black') + p <- p + annotate("text", x = max.count.pos - 0.02 * T.gap, + y = max(data.toplottr$ymax) + 0.2 * rect.length, + label = max(NCOUNT), size = cex.text * 0.8, hjust = 0.5) +} +if (is.null(main) == TRUE) { + p <- p + ggtitle(maintext) + theme(plot.title = element_text(hjust = 0.5)) +} else if (main!=""){ + p <- p + ggtitle(main) +} + +if (is.null(save_path) == FALSE){ + filename <- file.path(save_path, paste0("plot_avg.png")) + ggsave(filename,p) + } + + } + else if(type == 'dynamic' & version == 'seperate'){ + CI <- NULL #decide if we need plot uncertainties + if ("est.att" %in% names(x[[1]])){ + if(! is.null(x[[1]]$est.att)){ + CI <- TRUE + } + } + if (is.null(CI)) { + CI <- FALSE + } + if(plot.ci=="none"){ + CI <- FALSE + } + p_collection = list() + + for (i in 1:length(x)){ + ## axes labels + if (is.null(xlab) == TRUE) { + xlab <- "Time since the Treatment began" + } + else if (xlab == "") { + xlab <- NULL + } + + if (is.null(ylab) == TRUE) { + ylab <- ytitle + } + else if (ylab == "") { + ylab <- NULL + } + + ## y=0 line type + lcolor <- "white" + lwidth <- 2 + if (theme.bw == TRUE) { + lcolor <- "#AAAAAA70" + lwidth <- 1.5 + } + + if (CI == FALSE) { + message("Uncertainty estimates not available.\n") + temp.att <- x[[i]]$att + temp.time <- x[[i]]$time + temp.count <- x[[i]]$count + YVAR = rep(NA,length(temp.att)) + XVAR = rep(NA,length(temp.time)) + NCOUNT = rep(NA,length(temp.count)) + for (j in 1:length(temp.att)){ + YVAR[j] = temp.att[j] + XVAR[j] = temp.time[j] + NCOUNT[j] = temp.count[j] + } + data.toplot.main <- cbind.data.frame(YVAR,XVAR) + + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YVAR), na.rm = TRUE) - min(c(YVAR), na.rm = TRUE))/2 + rect.min <- min(c(YVAR), na.rm = TRUE) - rect.length + } + } else { + temp.est.att = x[[i]]$est.att + temp.time <- x[[i]]$time + rm.pos <- which(is.na(temp.est.att[,3])) + if (length(rm.pos) != 0){ + temp.est.att <- temp.est.att[-rm.pos,] + temp.time <- x$time.HTE[[i]][-rm.pos] + } + YVAR = rep(NA,dim(temp.est.att)[1]) + XVAR = rep(NA,dim(temp.est.att)[1]) + YMIN = rep(NA,dim(temp.est.att)[1]) + YMAX = rep(NA,dim(temp.est.att)[1]) + NCOUNT = rep(NA,dim(temp.est.att)[1]) + for (j in 1:dim(temp.est.att)[1]){ + YVAR[j] = temp.est.att[j,1] + YMIN[j] = temp.est.att[j,3] + YMAX[j] = temp.est.att[j,4] + XVAR[j] = temp.time[j] + NCOUNT[j] = temp.est.att[j,6] + } + data.toplot.main <- cbind.data.frame(YVAR,YMIN,YMAX,XVAR) + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YMAX), na.rm = TRUE) - min(c(YMIN), na.rm = TRUE))/2 + rect.min <- min(c(YMIN), na.rm = TRUE) - rect.length + } + } + + temp.p <- ggplot(data.toplot.main) + ## xlab and ylab + temp.p <- temp.p + xlab(xlab) + ylab(ylab) + + ## theme + if (theme.bw == TRUE) { + temp.p <- temp.p + theme_bw() + } + + ## grid + if (gridOff == TRUE) { + temp.p <- temp.p + theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + } + + # horizontal 0 line + #temp.p <- temp.p + geom_hline(yintercetemp.pt = 0, colour = lcolor,size = lwidth) + + + if(CI==FALSE){ + #temp.p <- temp.p + geom_point(aes(x=XVAR,y=YVAR,color='gray50',fill='gray50',alpha=1,size=1.2)) + temp.p <- temp.p + geom_point(aes(x=XVAR,y=YVAR),color='gray50',fill='gray50',alpha=1) + } else { + #temp.p <- temp.p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX,color='gray50',fill='gray50',alpha=1,size=0.6)) + temp.p <- temp.p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX),color='gray50',fill='gray50',alpha=1) + } + if(count==TRUE){ + + T.start <- c() + T.end <- c() + ymin <- c() + ymax <- c() + T.gap <- (max(XVAR)-min(XVAR))/length(XVAR) + for(j in c(1:length(XVAR))){ + T.start <- c(T.start,XVAR[j]-0.25*T.gap) + T.end <- c(T.end,XVAR[j]+0.25*T.gap) + ymin <- c(ymin, rect.min) + ymax <- c(ymax, rect.min+rect.length*NCOUNT[j]/max(NCOUNT)) + } + data.toplot <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymin, + ymax=ymax) + max.count.pos <- mean(XVAR[which.max(NCOUNT)]) + temp.p <- temp.p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplot,fill='gray50',alpha=0.3,size=0.3,color='black') + temp.p <- temp.p + annotate("text", x = max.count.pos - 0.02 * T.gap, + y = max(data.toplot$ymax) + 0.2 * rect.length, + label = max(NCOUNT), size = cex.text * 0.8, hjust = 0.5) + } + ## title + if (is.null(main) == TRUE) { + temp.title = paste0("Dynamic Effect when Moderator = ",x[[i]]$ValHTE) + temp.p <- temp.p + ggtitle(temp.title) + theme(plot.title = element_text(hjust = 0.5)) + } else if (main!=""){ + temp.p <- temp.p + ggtitle(main) + } + + p_collection[[i]] = temp.p + + if (is.null(save_path) == FALSE){ + filename <- file.path(save_path, paste0("plot_dynamic_",i,".png")) + ggsave(filename,temp.p) + } + + } + p <- plot_grid(plotlist = p_collection, ncol = 1) + } + + else if(type == "avg" & version == 'whole'){ + CI <- NULL #decide if we need plot uncertainties + if ("est.avg.HTE" %in% names(x)){ + CI <- TRUE + } + if (is.null(CI)) { + CI <- FALSE + } + if(plot.ci=="none"){ + CI <- FALSE + } + ## axes labels + if (is.null(xlab) == TRUE) { + xlab <- "Moderator" + } + else if (xlab == "") { + xlab <- NULL + } + + if (is.null(ylab) == TRUE) { + ylab <- ytitle + } + else if (ylab == "") { + ylab <- NULL + } + + ## y=0 line type + lcolor <- "white" + lwidth <- 2 + if (theme.bw == TRUE) { + lcolor <- "#AAAAAA70" + lwidth <- 1.5 + } + + if (CI == FALSE) { + message("Uncertainty estimates not available.\n") + YVAR = rep(NA,length(x$avg.HTE)) + XVAR = rep(NA,length(x$avg.HTE)) + for (i in 1:length(x$avg.HTE)){ + YVAR[i] = x$avg.HTE[i] + XVAR[i] = x$Val.HTE[i] + } + data.toplot.main <- cbind.data.frame(YVAR,XVAR) + + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YVAR), na.rm = TRUE) - min(c(YVAR), na.rm = TRUE))/2 + rect.min <- min(c(YVAR), na.rm = TRUE) - rect.length + } + } + else { + YVAR = rep(NA,length(x$avg.HTE)) + XVAR = rep(NA,length(x$avg.HTE)) + YMIN = rep(NA,length(x$avg.HTE)) + YMAX = rep(NA,length(x$avg.HTE)) + for (i in 1:length(x$avg.HTE)){ + YVAR[i] = x$est.avg.HTE[i,1] + YMIN[i] = x$est.avg.HTE[i,3] + YMAX[i] = x$est.avg.HTE[i,4] + XVAR[i] = x$Val.HTE[i] + } + data.toplot.main <- cbind.data.frame(YVAR,YMIN,YMAX,XVAR) + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YMAX), na.rm = TRUE) - min(c(YMIN), na.rm = TRUE))/2 + rect.min <- min(c(YMIN), na.rm = TRUE) - rect.length + } + } + + p <- ggplot(data.toplot.main) + ## xlab and ylab + p <- p + xlab(xlab) + ylab(ylab) + if(x$DataType == "continuous"){ + x_labels = rep("",length(XVAR)) + for(i in 1:length(XVAR)){ + if (i == 1){ + x_labels[i] = paste("0%-",round(100*XVAR[i],1),"%") + } + else{ + x_labels[i] = paste(round(100*XVAR[i-1],1),"%-",round(100*XVAR[i],1),"%") + } + + } + p <- p + scale_x_continuous(breaks = XVAR, labels = x_labels) + } + ## theme + if (theme.bw == TRUE) { + p <- p + theme_bw() + } + + ## grid + if (gridOff == TRUE) { + p <- p + theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + } + + # horizontal 0 line + #p <- p + geom_hline(yintercept = 0, colour = lcolor,size = lwidth) + + + if(CI==FALSE){ + #p <- p + geom_point(aes(x=XVAR,y=YVAR,color='gray50',fill='gray50',alpha=1,size=1.2)) + p <- p + geom_point(aes(x=XVAR,y=YVAR),color='gray50',fill='gray50',alpha=1) + } else { + #p <- p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX,color='gray50',fill='gray50',alpha=1,size=0.6)) + p <- p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX),color='gray50',fill='gray50',alpha=1) + } + if(count==TRUE){ + NcoCOUNT = rep(NA,length(x$avg.HTE)) + NtrCOUNT = rep(NA,length(x$avg.HTE)) + NCOUNT = rep(NA,length(x$avg.HTE)) + for (i in 1:length(x$avg.HTE)){ + # NtrCOUNT[i] = x[[i]]$NtrHTE + # NcoCOUNT[i] = x[[i]]$NHTE - NtrCOUNT[i] + NCOUNT[i] = x$N.HTE[i] + NtrCOUNT[i] = x$Ntr.HTE[i] + NcoCOUNT[i] = NCOUNT[i] - NtrCOUNT[i] + } + T.start <- c() + T.end <- c() + ymin <- c() + ymaxco <- c() + ymaxtr <- c() + T.gap <- (max(XVAR)-min(XVAR))/length(XVAR) + for(i in c(1:length(XVAR))){ + T.start <- c(T.start,XVAR[i]-0.25*T.gap) + T.end <- c(T.end,XVAR[i]+0.25*T.gap) + ymin <- c(ymin, rect.min) + ymaxco <- c(ymaxco, rect.min+rect.length*NcoCOUNT[i]/max(NCOUNT)) + ymaxtr <- c(ymaxtr, rect.min+rect.length*NCOUNT[i]/max(NCOUNT)) + } + data.toplotco <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymin, + ymax=ymaxco) + data.toplottr <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymaxco, + ymax=ymaxtr) + max.count.pos <- mean(XVAR[which.max(NCOUNT)]) + p <- p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplotco,fill='gray50',alpha=0.3,size=0.3,color='black') + p <- p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplottr,fill='red',alpha=0.3,size=0.3,color='black') + p <- p + annotate("text", x = max.count.pos - 0.02 * T.gap, + y = max(data.toplottr$ymax) + 0.2 * rect.length, + label = max(NCOUNT), size = cex.text * 0.8, hjust = 0.5) + } + if (is.null(main) == TRUE) { + p <- p + ggtitle(maintext) + theme(plot.title = element_text(hjust = 0.5)) + } else if (main!=""){ + p <- p + ggtitle(main) + } + + if (is.null(save_path) == FALSE){ + filename <- file.path(save_path, paste0("plot_avg.png")) + ggsave(filename,p) + } + } + + else if(type == 'dynamic' & version == 'whole'){ + CI <- NULL #decide if we need plot uncertainties + if ("est.att.HTE" %in% names(x)){ + if(! is.null(x$est.att.HTE)){ + CI <- TRUE + } + } + if (is.null(CI)) { + CI <- FALSE + } + if(plot.ci=="none"){ + CI <- FALSE + } + p_collection = list() + + for (i in 1:length(x$att.HTE)){ + ## axes labels + if (is.null(xlab) == TRUE) { + xlab <- "Moderator" + } + else if (xlab == "") { + xlab <- NULL + } + + if (is.null(ylab) == TRUE) { + ylab <- ytitle + } + else if (ylab == "") { + ylab <- NULL + } + + ## y=0 line type + lcolor <- "white" + lwidth <- 2 + if (theme.bw == TRUE) { + lcolor <- "#AAAAAA70" + lwidth <- 1.5 + } + + if (CI == FALSE) { + message("Uncertainty estimates not available.\n") + temp.att <- x$att.HTE[[i]] + temp.time <- x$time.HTE[[i]] + temp.count <- x$count.HTE[[i]] + YVAR = rep(NA,length(temp.att)) + XVAR = rep(NA,length(temp.time)) + NCOUNT = rep(NA,length(temp.count)) + for (j in 1:length(temp.att)){ + YVAR[j] = temp.att[j] + XVAR[j] = temp.time[j] + NCOUNT[j] = temp.count[j] + } + data.toplot.main <- cbind.data.frame(YVAR,XVAR) + + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YVAR), na.rm = TRUE) - min(c(YVAR), na.rm = TRUE))/2 + rect.min <- min(c(YVAR), na.rm = TRUE) - rect.length + } + } + else { + temp.est.att = x$est.att.HTE[[i]] + temp.time <- x$time.HTE[[i]] + rm.pos <- which(is.na(temp.est.att[,3])) + if (length(rm.pos) != 0){ + temp.est.att <- temp.est.att[-rm.pos,] + temp.time <- x$time.HTE[[i]][-rm.pos] + } + YVAR = rep(NA,dim(temp.est.att)[1]) + XVAR = rep(NA,dim(temp.est.att)[1]) + YMIN = rep(NA,dim(temp.est.att)[1]) + YMAX = rep(NA,dim(temp.est.att)[1]) + NCOUNT = rep(NA,dim(temp.est.att)[1]) + for (j in 1:dim(temp.est.att)[1]){ + YVAR[j] = temp.est.att[j,1] + YMIN[j] = temp.est.att[j,3] + YMAX[j] = temp.est.att[j,4] + XVAR[j] = temp.time[j] + NCOUNT[j] = temp.est.att[j,6] + } + data.toplot.main <- cbind.data.frame(YVAR,YMIN,YMAX,XVAR) + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YMAX), na.rm = TRUE) - min(c(YMIN), na.rm = TRUE))/2 + rect.min <- min(c(YMIN), na.rm = TRUE) - rect.length + } + } + + temp.p <- ggplot(data.toplot.main) + ## xlab and ylab + temp.p <- temp.p + xlab(xlab) + ylab(ylab) + + ## theme + if (theme.bw == TRUE) { + temp.p <- temp.p + theme_bw() + } + + ## grid + if (gridOff == TRUE) { + temp.p <- temp.p + theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + } + + # horizontal 0 line + #temp.p <- temp.p + geom_hline(yintercetemp.pt = 0, colour = lcolor,size = lwidth) + + + if(CI==FALSE){ + #temp.p <- temp.p + geom_point(aes(x=XVAR,y=YVAR,color='gray50',fill='gray50',alpha=1,size=1.2)) + temp.p <- temp.p + geom_point(aes(x=XVAR,y=YVAR),color='gray50',fill='gray50',alpha=1) + } else { + #temp.p <- temp.p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX,color='gray50',fill='gray50',alpha=1,size=0.6)) + temp.p <- temp.p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX),color='gray50',fill='gray50',alpha=1) + } + if(count==TRUE){ + + T.start <- c() + T.end <- c() + ymin <- c() + ymax <- c() + T.gap <- (max(XVAR)-min(XVAR))/length(XVAR) + for(j in c(1:length(XVAR))){ + T.start <- c(T.start,XVAR[j]-0.25*T.gap) + T.end <- c(T.end,XVAR[j]+0.25*T.gap) + ymin <- c(ymin, rect.min) + ymax <- c(ymax, rect.min+rect.length*NCOUNT[j]/max(NCOUNT)) + } + data.toplot <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymin, + ymax=ymax) + max.count.pos <- mean(XVAR[which.max(NCOUNT)]) + temp.p <- temp.p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplot,fill='gray50',alpha=0.3,size=0.3,color='black') + temp.p <- temp.p + annotate("text", x = max.count.pos - 0.02 * T.gap, + y = max(data.toplot$ymax) + 0.2 * rect.length, + label = max(NCOUNT), size = cex.text * 0.8, hjust = 0.5) + } + ## title + if (is.null(main) == TRUE) { + temp.title = paste0("Dynamic Effect when Moderator = ",x$Val.HTE[i]) + temp.p <- temp.p + ggtitle(temp.title) + theme(plot.title = element_text(hjust = 0.5)) + } else if (main!=""){ + temp.p <- temp.p + ggtitle(main) + } + p_collection[[i]] = temp.p + + if (is.null(save_path) == FALSE){ + filename <- file.path(save_path, paste0("plot_dynamic_",i,".png")) + ggsave(filename,temp.p) + } + } + p <- plot_grid(plotlist = p_collection, ncol = 1) +} +## ylim +# if (is.null(ylim) == FALSE) { +# p <- p + coord_cartesian(ylim = ylim) +# } + +# if(length(XVAR)<=10){ +# p <- p + scale_x_continuous(breaks=XVAR) +# } else { +# p <- p + scale_x_continuous(labels=scaleFUN) +# } + +# ## xlim +# if(is.null(xlim)){ +# if(is.na(d1[1,1])){ +# ## drop all periods before first non-missing +# for(j in c(2:dim(d1)[1])){ +# if(!is.na(d1[j,1])){ +# xlim <- c(XVAR[j],max(XVAR)) +# break +# } +# } +# } +# } +## xlim +# if (is.null(xlim) == FALSE) { +# p <- p + coord_cartesian(xlim = xlim) +# } + + +# p <- p + geom_hline(yintercept = x$att.avg,color='red',size=0.8,linetype='dashed') +# +# p <- p + theme(legend.text = element_text(margin = margin(r = 10, unit = "pt"), size = cex.legend), +# legend.position = legend.pos, +# legend.background = element_rect(fill="transparent",colour=NA), +# axis.title=element_text(size=cex.lab), +# axis.title.x = element_text(margin = margin(t = 8, r = 0, b = 0, l = 0)), +# axis.title.y = element_text(margin = margin(t = 0, r = 0, b = 0, l = 0)), +# axis.text = element_text(color="black", size=cex.axis), +# #axis.text.x = element_text(size = cex.axis, angle = angle, hjust=x.h, vjust=x.v), +# axis.text.x = element_text(size = cex.axis, angle = angle), +# axis.text.y = element_text(size = cex.axis), +# plot.title = element_text(size = cex.main, hjust = 0.5, face="bold", margin = margin(10, 0, 10, 0))) +return(p) +} diff --git a/R/boot.R b/R/boot.R index 8b2a1f8..2a964a6 100644 --- a/R/boot.R +++ b/R/boot.R @@ -1,5 +1,5 @@ ############################################### -## Inference +## Inference ############################################### fect.boot <- function(Y, X, @@ -7,9 +7,9 @@ fect.boot <- function(Y, W, cl = NULL, I, - II, - T.on, - T.off = NULL, + II, + T.on, + T.off = NULL, T.on.carry = NULL, T.on.balance = NULL, balance.period = NULL, @@ -22,17 +22,17 @@ fect.boot <- function(Y, criterion = "mspe", CV, k = 5, - cv.prop = 0.1, - cv.treat = 0, + cv.prop = 0.1, + cv.treat = 0, cv.nobs = 1, - r = 0, + r = 0, r.end, lambda = NULL, nlambda = 10, alpha = 0.05, - binary, + binary = FALSE, QR, - force, + force, hasRevs = 1, tol, max.iteration = 1000, @@ -48,9 +48,14 @@ fect.boot <- function(Y, cores = NULL, group.level = NULL, group = NULL, - dis = TRUE) { - - + dis = TRUE, + HTEid = NULL, + moderator.type = NULL, + moderator.nbins = 3, + HTE.enp.seq = NULL + ) { + + na.pos <- NULL TT <- dim(Y)[1] N <- dim(Y)[2] @@ -85,56 +90,84 @@ fect.boot <- function(Y, Nrev <- length(rev) Ntr <- length(tr) Nco <- length(co) - } + } else { ## treatement indicator tr <- which(apply(D, 2, sum) > 0) co <- which(apply(D, 2, sum) == 0) Ntr <- length(tr) Nco <- length(co) - } + if(length(HTEid) == 1){ #for HTE estimation, get the number of bins + #check the key option moderator.type + if(!is.null(moderator.type)){ + if(! moderator.type %in% c("discrete","continuous")){ + stop("\"moderator.type\" option misspecified. Must be one of followings:\"discrete\",\"continuous\".") + } + } + else { + HTEuni = unique(as.vector(HTEvalue)) + if (length(HTEuni) > 5){ + moderator.type = "continuous" + } else{ + moderator.type = "discrete" + } + } + + if (moderator.type == "discrete"){ + HTEvalue = X[,,HTEid] + HTEuni = unique(as.vector(HTEvalue)) + nbins = length(HTEuni) + } + else if (moderator.type == "continuous"){ + nbins = moderator.nbins + } + } + - ## estimation - if (CV == 0) { + if (CV == 0) { if(method == "gsynth"){ - out <- fect.gsynth(Y = Y, X = X, D = D, W = W, I = I, II = II, - T.on = T.on, T.off = T.off, CV = 0, + out <- fect.gsynth(Y = Y, X = X, D = D, W = W, I = I, II = II, + T.on = T.on, T.off = T.off, CV = 0, T.on.balance = T.on.balance, balance.period = balance.period, r = r, binary = binary, QR = QR, - force = force, hasRevs = hasRevs, + force = force, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 0, - norm.para = norm.para, + norm.para = norm.para, placebo.period = placebo.period, placeboTest = placeboTest, carryover.period = carryover.period, carryoverTest = carryoverTest, group.level = group.level, group = group) - } + } else if (method == "ife") { - out <- fect.fe(Y = Y, X = X, D = D, W = W, I = I, II = II, + out <- fect.fe(Y = Y, X = X, D = D, W = W, I = I, II = II, T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, T.on.balance = T.on.balance, balance.period = balance.period, r.cv = r, binary = binary, QR = QR, - force = force, hasRevs = hasRevs, + force = force, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 0, - norm.para = norm.para, + norm.para = norm.para, placebo.period = placebo.period, placeboTest = placeboTest, carryover.period = carryover.period, carryoverTest = carryoverTest, - group.level = group.level, group = group) - + group.level = group.level, group = group, + HTEid = HTEid, + moderator.type = moderator.type, + moderator.nbins = moderator.nbins, + HTE.enp.seq = HTE.enp.seq) + } else if (method == "mc") { out <- try(fect.mc(Y = Y, X = X, D = D, W = W, I = I, II = II, T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, T.on.balance = T.on.balance, balance.period = balance.period, - lambda.cv = lambda, force = force, hasRevs = hasRevs, + lambda.cv = lambda, force = force, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 0, norm.para = norm.para, placebo.period = placebo.period, @@ -145,25 +178,25 @@ fect.boot <- function(Y, if ('try-error' %in% class(out)) { stop("\nCannot estimate using full data with MC algorithm.\n") } - } + } else if (method %in% c("polynomial", "bspline","cfe")) { - out <- try(fect.polynomial(Y = Y, D = D, X = X, W = W, I = I, + out <- try(fect.polynomial(Y = Y, D = D, X = X, W = W, I = I, II = II, T.on = T.on, T.on.carry = T.on.carry, T.on.balance = T.on.balance, balance.period = balance.period, T.off = T.off, method = method,degree = degree, - knots = knots, force = force, + knots = knots, force = force, sfe = sfe, cfe = cfe, ind.matrix = ind.matrix, hasRevs = hasRevs, - tol = tol, max.iteration = max.iteration, boot = 0, + tol = tol, max.iteration = max.iteration, boot = 0, placeboTest = placeboTest, - placebo.period = placebo.period, + placebo.period = placebo.period, carryover.period = carryover.period, carryoverTest = carryoverTest, norm.para = norm.para, - group.level = group.level, + group.level = group.level, group = group),silent = TRUE) #I.report <- out$I #II.report <- out$II @@ -171,40 +204,44 @@ fect.boot <- function(Y, stop("\nCannot estimate.\n") } } - } + } else { - ## cross-valiadtion + ## cross-valiadtion if (binary == 0) { - out <- fect.cv(Y = Y, X = X, D = D, W = W, I = I, II = II, + out <- fect.cv(Y = Y, X = X, D = D, W = W, I = I, II = II, T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, T.on.balance = T.on.balance, balance.period = balance.period, method = method, criterion = criterion, - k = k, r = r, r.end = r.end, - nlambda = nlambda, lambda = lambda, - force = force, hasRevs = hasRevs, + k = k, r = r, r.end = r.end, + nlambda = nlambda, lambda = lambda, + force = force, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, norm.para = norm.para, group.level = group.level, group = group, - cv.prop = cv.prop, cv.treat = cv.treat, - cv.nobs = cv.nobs) + cv.prop = cv.prop, cv.treat = cv.treat, + cv.nobs = cv.nobs, + HTEid = HTEid, + moderator.type = moderator.type, + moderator.nbins = moderator.nbins, + HTE.enp.seq = HTE.enp.seq) method <- out$method - } + } else { - out <- fect.binary.cv(Y = Y, X = X, D = D, - I = I, II = II, - T.on = T.on, T.off = T.off, - k = k, r = r, r.end = r.end, - QR = QR, force = force, + out <- fect.binary.cv(Y = Y, X = X, D = D, + I = I, II = II, + T.on = T.on, T.off = T.off, + k = k, r = r, r.end = r.end, + QR = QR, force = force, hasRevs = hasRevs, tol = tol, group.level = group.level, group = group) method <- "ife" } - + } - - - + + + ## output validX <- out$validX eff <- out$eff @@ -213,12 +250,30 @@ fect.boot <- function(Y, calendar.eff <- out$eff.calendar calendar.eff.fit <- out$eff.calendar.fit calendar.N <- out$N.calendar + avg.HTE <- out$avg.HTE + avg.HTE.fit <- out$avg.HTE.fit + N.HTE <- out$N.HTE + Val.HTE <- out$Val.HTE + # HTEbootVal <- out$bootVal + # HTEcoef <- out$HTEcoef + + if(length(HTEid) != 1){ + est.avg.HTE = NULL + est.avg.HTE.fit = NULL + est.HTEcoef = NULL + Val.HTE = NULL + } + group.att <- out$group.att att <- out$att time.on <- out$time target.enp <- out$calendar.enp + HTE.enp <- out$HTE.enp + + # att.HTE <- out$att.HTE + # time.HTE <- out$time.HTE time.off <- NULL if (hasRevs == 1) { @@ -228,7 +283,7 @@ fect.boot <- function(Y, carry.att <- carry.time <- NULL if (!is.null(T.on.carry)) { carry.att <- out$carry.att - carry.time <- out$carry.time + carry.time <- out$carry.time } if(!is.null(balance.period)){ @@ -240,7 +295,7 @@ fect.boot <- function(Y, balance.att.placebo <- out$balance.att.placebo } } - + if(!is.null(W)){ att.avg.W <- out$att.avg.W att.on.sum.W <- out$att.on.sum.W @@ -289,15 +344,15 @@ fect.boot <- function(Y, if (is.null(cl)) { cl.unique <- NULL } else { - cl.unique <- unique(c(cl)) + cl.unique <- unique(cl) } if (vartype == "jackknife") { nboots <- N } - + ## bootstrapped estimates - ## eff.boot <- array(0,dim = c(TT, Ntr, nboots)) ## to store results + eff.boot <- array(NA,dim = c(TT, N, nboots)) ## to store results att.avg.boot <- matrix(0, 1, nboots) att.avg.unit.boot <- matrix(0, 1, nboots) att.boot <- matrix(0, length(time.on), nboots) @@ -306,16 +361,36 @@ fect.boot <- function(Y, calendar.eff.boot <- matrix(0,TT,nboots) calendar.eff.fit.boot <- matrix(0,TT,nboots) + + + if(length(HTEid) == 1){ + avg.HTE.boot <- matrix(0,nbins,nboots) + avg.HTE.fit.boot <- matrix(0,nbins,nboots) + + att.boot.HTE = list() + for (i in c(1:length(out$att.HTE))){ + att.boot.HTE[[i]] = matrix(0,length(out$time.HTE[[i]]),nboots) + } + HTE.eff.boot <- matrix(0,length(N.HTE),nboots) + HTE.eff.fit.boot <- matrix(0,length(N.HTE),nboots) + # HTEcoef.boot <- matrix(0,1,nboots) + } + + # att.HTE.boot <- list() + # for (i in c(1:length(att.HTE))){ + # att.HTE.boot[[i]] <- matrix(0,length(time.HTE[[i]]),nboots) + # } + if (hasRevs == 1) { - att.off.boot <- matrix(0, length(time.off), nboots) - att.off.count.boot <- matrix(0, length(time.off), nboots) + att.off.boot <- matrix(0, length(time.off), nboots) + att.off.count.boot <- matrix(0, length(time.off), nboots) } if (!is.null(T.on.carry)) { carry.att.boot <- matrix(0, length(carry.att), nboots) } if (!is.null(balance.period)) { balance.att.boot <- matrix(0, length(balance.att), nboots) # dynamic att - balance.count.boot <- matrix(0, length(balance.att), nboots) + balance.count.boot <- matrix(0, length(balance.att), nboots) balance.avg.att.boot <- matrix(0, 1, nboots) if (!is.null(placebo.period) & placeboTest == TRUE) { balance.att.placebo.boot <- matrix(0, 1, nboots) @@ -379,7 +454,7 @@ fect.boot <- function(Y, if(carryoverTest){ group.att.carryover.boot[[sub.name]] <- matrix(0, 1, nboots) } - } + } } if (dis) { @@ -409,7 +484,7 @@ fect.boot <- function(Y, } boot <- try(fect.fe(Y = Y.boot, X = X, D = D, W = W, - I = I, II = II, + I = I, II = II, T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, T.on.balance = T.on.balance, balance.period = balance.period, @@ -418,13 +493,14 @@ fect.boot <- function(Y, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 1, norm.para = norm.para, calendar.enp.seq = target.enp, - time.on.seq = time.on, - time.off.seq = time.off, - time.on.carry.seq = carry.time, - time.on.balance.seq = balance.time, - time.on.seq.W = time.on.W, - time.off.seq.W = time.off.W, - placebo.period = placebo.period.boot, + HTE.enp.seq = HTE.enp, + # time.on.seq = time.on, + # time.off.seq = time.off, + # time.on.carry.seq = carry.time, + # time.on.balance.seq = balance.time, + # time.on.seq.W = time.on.W, + # time.off.seq.W = time.off.W, + placebo.period = placebo.period.boot, placeboTest = placeboTest, carryoverTest = carryoverTest, carryover.period = carryover.period.boot, @@ -432,12 +508,12 @@ fect.boot <- function(Y, group = group), silent = TRUE) if ('try-error' %in% class(boot)) { - boot0 <- list(att.avg = NA, att = NA, count = NA, - beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, + boot0 <- list(att.avg = NA, att = NA, count = NA, + beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, eff.calendar.fit = NA, att.placebo = NA, att.avg.unit = NA, att.carryover = NA, - group.att = NA, marginal = NA,carry.att = NA,balance.att = NA, - balance.att.placebo = NA, balance.count = NA, + group.att = NA, marginal = NA,carry.att = NA,balance.att = NA, + balance.att.placebo = NA, balance.count = NA, att.avg.W = NA, att.on.W = NA, count.on.W = NA, time.on.W = NA, att.placebo.W = NA, att.off.W = NA, count.off.W = NA, time.off.W = NA, att.carryover.W = NA, balance.avg.att = NA, balance.time = NA,group.output = list()) @@ -461,13 +537,13 @@ fect.boot <- function(Y, error.co <- out$res.full[,id.co] I.co <- out$I[,id.co] - T0.ub <- apply(as.matrix(out$D[,id.tr] == 0), 2, sum) + T0.ub <- apply(as.matrix(out$D[,id.tr] == 0), 2, sum) T0.ub.min <- min(T0.ub) co.pre <- apply(as.matrix(I.co[1:T0.ub.min, ]), 2, sum) co.post <- apply(as.matrix(I.co[(max(T0.ub)+1):TT, ]), 2, sum) if (force %in% c(1, 3)) { valid.co <- id.co[(co.pre >= (out$r.cv + 1)) & (co.post >= 1)] - } + } else { valid.co <- id.co[(co.pre >= out$r.cv) & (co.post >= 1)] } @@ -479,7 +555,7 @@ fect.boot <- function(Y, break } } - + id.co.rest <- id.co[which(!id.co %in% fake.tr)] repeat { id.co.pseudo <- sample(id.co.rest, Nco, replace = TRUE) @@ -487,15 +563,15 @@ fect.boot <- function(Y, break } } - + id.pseudo <- c(rep(fake.tr, Ntr), id.co.pseudo) ## Ntr + ... - I.id.pseudo <- out$I[, id.pseudo] + I.id.pseudo <- out$I[, id.pseudo] II.id.pseudo <- out$II[,id.pseudo] ## obtain the prediction eror D.pseudo <- out$D[, c(id.tr, id.co.pseudo)] ## fake.tr + control left Y.pseudo <- out$Y[, id.pseudo] T.on.pseudo <- T.on[,id.pseudo] - + X.pseudo <- NULL if (p > 0) { X.pseudo <- X[,id.pseudo,,drop = FALSE] @@ -512,25 +588,25 @@ fect.boot <- function(Y, T.on = T.on.pseudo, hasRevs = hasRevs, force = force, r = out$r.cv, CV = 0, tol = tol, max.iteration = max.iteration, norm.para = norm.para, boot = 1), silent = TRUE) - + if ('try-error' %in% class(synth.out)) { return(matrix(NA, TT, Ntr)) - } + } else { if ("eff" %in% names(synth.out)) { if (is.null(norm.para)) { output <- synth.out$eff.tr - } + } else { output <- synth.out$eff.tr/norm.para[1] } - + return(as.matrix(output)) ## TT * Ntr - } + } else { return(matrix(NA, TT, Ntr)) } - } + } } message("\rSimulating errors ...") @@ -542,8 +618,8 @@ fect.boot <- function(Y, .packages = c("fect","mvtnorm","fixest"), .inorder = FALSE) %dopar% { return(draw.error()) - } - } + } + } else { error.tr <- array(NA, dim = c(TT, Ntr, nboots)) for (j in 1:nboots) { @@ -554,7 +630,7 @@ fect.boot <- function(Y, } } - + if (0%in%I) { ## calculate vcov of ep_tr @@ -578,13 +654,13 @@ fect.boot <- function(Y, for(i in 1:Ntr){ vcov_tr[,,i] <- res.vcov(res = error.tr.adj[,,i],cov.ar = 0) vcov_tr[,,i][is.na(vcov_tr[,,i]) | is.nan(vcov_tr[,,i])] <- 0 - } + } ## calculate vcov of e_co vcov_co <- res.vcov(res = error.co, cov.ar = 0) vcov_co[is.na(vcov_co) | is.nan(vcov_co)] <- 0 } - + one.nonpara <- function(num = NULL){ ## boostrap ID repeat { @@ -594,32 +670,32 @@ fect.boot <- function(Y, } } id.boot <- c(id.tr, fake.co) - + ## get the error for the treated and control error.tr.boot <- matrix(NA, TT, Ntr) - if (0 %in% I) { + if (0 %in% I) { for (w in 1:Ntr) { error.tr.boot[,w] <- t(rmvnorm(n = 1, rep(0, TT), vcov_tr[,,w], method = "svd")) - } + } error.tr.boot[which(I.tr == 0)] <- 0 error.co.boot <- t(rmvnorm(n = Nco, rep(0, TT), vcov_co, method = "svd")) - error.co.boot[which(as.matrix(I[,fake.co]) == 0)] <- 0 - } + error.co.boot[which(as.matrix(I[,fake.co]) == 0)] <- 0 + } else { for (w in 1:Ntr) { error.tr.boot[,w] <- error.tr[,w,sample(1:nboots,1,replace = TRUE)] } - error.co.boot <- error.co[, sample(1:Nco, Nco, replace = TRUE)] + error.co.boot <- error.co[, sample(1:Nco, Nco, replace = TRUE)] } Y.boot <- fit.out[,id.boot] Y.boot[,1:Ntr] <- as.matrix(Y.boot[,1:Ntr] + error.tr.boot) - Y.boot[,(Ntr+1):length(id.boot)] <- Y.boot[,(Ntr+1):length(id.boot)] + error.co.boot + Y.boot[,(Ntr+1):length(id.boot)] <- Y.boot[,(Ntr+1):length(id.boot)] + error.co.boot X.boot <- NULL if (p > 0) { - X.boot <- X[,id.boot,,drop = FALSE] + X.boot <- X[,id.boot,,drop = FALSE] } - D.boot <- out$D[,id.boot] + D.boot <- out$D[,id.boot] I.boot <- out$I[,id.boot] II.boot <- out$II[,id.boot] W.boot <- NULL @@ -627,17 +703,18 @@ fect.boot <- function(Y, W.boot <- NULL } synth.out <- try(fect.gsynth(Y = Y.boot, X = X.boot, D = D.boot, W = W.boot, - I = I.boot, II = II.boot,T.on = T.on[,id.boot], + I = I.boot, II = II.boot,T.on = T.on[,id.boot], T.on.balance = T.on.balance[,id.boot], balance.period = balance.period, hasRevs = hasRevs, force = force, r = out$r.cv, CV = 0, boot = 1, placeboTest = placeboTest, - placebo.period = placebo.period, + placebo.period = placebo.period, carryover.period = carryover.period, carryoverTest = carryoverTest, calendar.enp.seq = target.enp, - time.on.seq = time.on, + #HTE.enp.seq = HTE.enp, + time.on.seq = time.on, time.off.seq = time.off, time.on.seq.W = time.on.W, time.off.seq.W = time.off.W, @@ -648,12 +725,12 @@ fect.boot <- function(Y, group.level = group.level, group = group), silent = TRUE) if ('try-error' %in% class(synth.out)) { - boot0 <- list(att.avg = NA, att = NA, count = NA, - beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, + boot0 <- list(att.avg = NA, att = NA, count = NA, + beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, eff.calendar.fit = NA, att.placebo = NA, att.avg.unit = NA, att.carryover = NA, group.att = NA, marginal = NA, - balance.att = NA, balance.att.placebo = NA, balance.count = NA, + balance.att = NA, balance.att.placebo = NA, balance.count = NA, balance.avg.att = NA, balance.time = NA, att.avg.W = NA, att.on.W = NA, count.on.W = NA, time.on.W = NA, att.placebo.W = NA, att.off.W = NA, count.off.W = NA, time.off.W = NA, att.carryover.W = NA, @@ -676,16 +753,16 @@ fect.boot <- function(Y, fit.out[which(out$I==0)] <- 0 error.co <- out$res[,co] #error.tr <- out$eff[,tr] - + if (0%in%out$I) { vcov_co <- res.vcov(res = error.co, cov.ar = 0) vcov_co[is.na(vcov_co)|is.nan(vcov_co)] <- 0 #vcov_tr <- res.vcov(res = error.tr, cov.ar = 0) #vcov_tr[is.na(vcov_tr)|is.nan(vcov_tr)] <- 0 } - + one.nonpara <- function(num = NULL){ - error.id <- sample(1:Nco, N, replace = TRUE) + error.id <- sample(1:Nco, N, replace = TRUE) ## produce the new outcome data if (0%in%I) { @@ -694,50 +771,55 @@ fect.boot <- function(Y, #error.boot.tr <- t(rmvnorm(n=Ntr,rep(0,TT),vcov_tr,method="svd")) Y.boot <- fit.out + out$eff + error.boot #Y.boot <- fit.out - #Y.boot[,tr] <- Y.boot[,tr] + error.boot.tr - #Y.boot[,co] <- Y.boot[,co] + error.boot.co - } + #Y.boot[,tr] <- Y.boot[,tr] + error.boot.tr + #Y.boot[,co] <- Y.boot[,co] + error.boot.co + } else { Y.boot <- fit.out + out$eff + error.co[,error.id] #Y.boot <- fit.out #Y.boot[,tr] <- Y.boot[,tr] + error.tr[,error.id.tr] #Y.boot[,co] <- Y.boot[,co] + error.co[,error.id.co] } - + if (method == "ife") { - boot <- try(fect.fe(Y = Y.boot, X = X, D = D, - W = W, I = I, II = II, + boot <- try(fect.fe(Y = Y.boot, X = X, D = D, + W = W, I = I, II = II, T.on = T.on, T.off = T.off,T.on.carry = T.on.carry, T.on.balance = T.on.balance, balance.period = balance.period, r.cv = out$r.cv, binary = binary, QR = QR, - force = force, hasRevs = hasRevs, + force = force, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 1, - norm.para = norm.para, + norm.para = norm.para, placebo.period = placebo.period, placeboTest = placeboTest, carryover.period = carryover.period, carryoverTest = carryoverTest, group.level = group.level, group = group, calendar.enp.seq = target.enp, - time.on.seq = time.on, - time.off.seq = time.off, - time.on.seq.W = time.on.W, - time.off.seq.W = time.off.W, - time.on.carry.seq = carry.time, - time.on.balance.seq = balance.time, - time.on.seq.group = group.time.on, - time.off.seq.group = group.time.off),silent = TRUE) - - } + HTE.enp.seq = HTE.enp, + # time.on.seq = time.on, + # time.off.seq = time.off, + # time.on.seq.W = time.on.W, + # time.off.seq.W = time.off.W, + # time.on.carry.seq = carry.time, + # time.on.balance.seq = balance.time, + # time.on.seq.group = group.time.on, + # time.off.seq.group = group.time.off, + HTEid = HTEid, + moderator.type = moderator.type, + moderator.nbins = moderator.nbins, + #HTEbootVal = HTEbootVal + ),silent = TRUE) + } else if (method == "mc") { - - boot <- try(fect.mc(Y = Y.boot, X = X, D = D, + + boot <- try(fect.mc(Y = Y.boot, X = X, D = D, W = W, I = I, II = II, T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, T.on.balance = T.on.balance, balance.period = balance.period, - lambda.cv = out$lambda.cv, force = force, hasRevs = hasRevs, + lambda.cv = out$lambda.cv, force = force, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 1, norm.para = norm.para, placebo.period = placebo.period, @@ -746,7 +828,8 @@ fect.boot <- function(Y, carryoverTest = carryoverTest, group.level = group.level, group = group, calendar.enp.seq = target.enp, - time.on.seq = time.on, + #HTE.enp.seq = HTE.enp, + time.on.seq = time.on, time.off.seq = time.off, time.on.seq.W = time.on.W, time.off.seq.W = time.off.W, @@ -755,28 +838,29 @@ fect.boot <- function(Y, time.on.seq.group = group.time.on, time.off.seq.group = group.time.off),silent = TRUE) - } + } else if (method %in% c("polynomial", "bspline","cfe")) { - boot <- try(fect.polynomial(Y = Y.boot, D = D, X = X, - W = W, I = I, - II = II, T.on = T.on, + boot <- try(fect.polynomial(Y = Y.boot, D = D, X = X, + W = W, I = I, + II = II, T.on = T.on, T.off = T.off,T.on.carry = T.on.carry, T.on.balance = T.on.balance, balance.period = balance.period, method = method,degree = degree, knots = knots, force = force, sfe = sfe, cfe = cfe, - ind.matrix = ind.matrix, + ind.matrix = ind.matrix, hasRevs = hasRevs, - tol = tol, max.iteration = max.iteration, boot = 1, + tol = tol, max.iteration = max.iteration, boot = 1, placeboTest = placeboTest, - placebo.period = placebo.period, + placebo.period = placebo.period, carryover.period = carryover.period, carryoverTest = carryoverTest, norm.para = norm.para, group.level = group.level, group = group, calendar.enp.seq = target.enp, - time.on.seq = time.on, + #HTE.enp.seq = HTE.enp, + time.on.seq = time.on, time.off.seq = time.off, time.on.seq.W = time.on.W, time.off.seq.W = time.off.W, @@ -787,12 +871,12 @@ fect.boot <- function(Y, } if ('try-error' %in% class(boot)) { - boot0 <- list(att.avg = NA, att = NA, count = NA, - beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, + boot0 <- list(att.avg = NA, att = NA, count = NA, + beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, eff.calendar.fit = NA, att.placebo = NA, att.avg.unit = NA, att.carryover = NA, - group.att = NA, marginal = NA,carry.att = NA, - balance.att = NA, balance.att.placebo = NA, balance.count = NA, + group.att = NA, marginal = NA,carry.att = NA, + balance.att = NA, balance.att.placebo = NA, balance.count = NA, balance.avg.att = NA, balance.time = NA, att.avg.W = NA, att.on.W = NA, count.on.W = NA, time.on.W = NA, att.placebo.W = NA, att.off.W = NA, count.off.W = NA, time.off.W = NA, att.carryover.W = NA, @@ -803,9 +887,9 @@ fect.boot <- function(Y, return(boot) } } - } + } else { - + one.nonpara <- function(num = NULL) { ## bootstrap if (is.null(num)) { if (is.null(cl)) { @@ -819,7 +903,7 @@ fect.boot <- function(Y, break } } - } + } else { repeat{ boot.id <- sample(tr, Ntr, replace=TRUE) @@ -828,7 +912,7 @@ fect.boot <- function(Y, } } } - } + } else { if (Ntr > 0) { if (Nco > 0) { @@ -841,7 +925,7 @@ fect.boot <- function(Y, break } } - } + } else { repeat{ fake.tr <- sample(tr, Ntr, replace=TRUE) @@ -852,7 +936,7 @@ fect.boot <- function(Y, } } } - } + } else { if (Nco > 0) { repeat{ @@ -863,7 +947,7 @@ fect.boot <- function(Y, break } } - } + } else { repeat{ boot.id <- sample(rev, Nrev, replace=TRUE) @@ -874,29 +958,26 @@ fect.boot <- function(Y, } } } - } + } else { - cl.id <- c(apply(cl,2,mean)) cl.boot <- sample(cl.unique, length(cl.unique), replace = TRUE) cl.boot.uni <- unique(cl.boot) cl.boot.count <- as.numeric(table(cl.boot)) boot.id <- c() for (kk in 1:length(cl.boot.uni)) { - boot.id <- c(boot.id, rep(which(cl.id == cl.boot.uni[kk]), cl.boot.count[kk])) + boot.id <- c(boot.id, rep(which(cl == cl.boot.uni[kk]), cl.boot.count[kk])) } - - } boot.group <- group[, boot.id] - } + } else { ## jackknife boot.group <- group[,-num] boot.id <- 1:N boot.id <- boot.id[-num] } - + X.boot <- X[,boot.id,,drop = FALSE] D.boot <- D[, boot.id] I.boot <- I[, boot.id] @@ -912,18 +993,18 @@ fect.boot <- function(Y, } if (sum(c(D.boot) == 0) == 0 | sum(c(D.boot) == 1) == 0 | sum(c(I.boot) == 1) == 0) { - boot0 <- list(att.avg = NA, att = NA, count = NA, - beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, + boot0 <- list(att.avg = NA, att = NA, count = NA, + beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, eff.calendar.fit = NA, att.placebo = NA, att.avg.unit = NA, att.carryover = NA, group.att = list(), - balance.att = NA, balance.att.placebo = NA, balance.count = NA, + balance.att = NA, balance.att.placebo = NA, balance.count = NA, balance.avg.att = NA, balance.time = NA, att.avg.W = NA, att.on.W = NA, count.on.W = NA, time.on.W = NA, att.placebo.W = NA, att.off.W = NA, count.off.W = NA, time.off.W = NA, att.carryover.W = NA, group.out = list()) return(boot0) - } + } else { T.off.boot <- NULL if (hasRevs == TRUE) { @@ -940,7 +1021,7 @@ fect.boot <- function(Y, if(method == "gsynth") { boot <- try(fect.gsynth(Y = Y[, boot.id], X = X.boot, D = D.boot, W = W.boot, - I = I.boot, II = II[, boot.id], + I = I.boot, II = II[, boot.id], T.on = T.on[, boot.id], T.off = T.off.boot, CV = 0, T.on.balance = T.on.balance[, boot.id], balance.period = balance.period, @@ -949,11 +1030,12 @@ fect.boot <- function(Y, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 1, norm.para = norm.para, calendar.enp.seq = target.enp, - time.on.seq = time.on, + #HTE.enp.seq = HTE.enp, + time.on.seq = time.on, time.off.seq = time.off, time.on.seq.W = time.on.W, time.off.seq.W = time.off.W, - placebo.period = placebo.period.boot, + placebo.period = placebo.period.boot, placeboTest = placeboTest, time.on.balance.seq = balance.time, carryoverTest = carryoverTest, @@ -961,12 +1043,12 @@ fect.boot <- function(Y, group.level = group.level, group = boot.group, time.on.seq.group = group.time.on, - time.off.seq.group = group.time.off) ) + time.off.seq.group = group.time.off) ) } else if (method == "ife") { boot <- try(fect.fe(Y = Y[, boot.id], X = X.boot, D = D.boot, W = W.boot, - I = I.boot, II = II[, boot.id], - T.on = T.on[, boot.id], T.off = T.off.boot, + I = I.boot, II = II[, boot.id], + T.on = T.on[, boot.id], T.off = T.off.boot, T.on.carry = T.on.carry[, boot.id], T.on.balance = T.on.balance[, boot.id], balance.period = balance.period, @@ -975,39 +1057,46 @@ fect.boot <- function(Y, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 1, norm.para = norm.para, calendar.enp.seq = target.enp, - time.on.seq = time.on, + HTE.enp.seq = HTE.enp, + time.on.seq = time.on, time.off.seq = time.off, time.on.seq.W = time.on.W, time.off.seq.W = time.off.W, time.on.carry.seq = carry.time, time.on.balance.seq = balance.time, - placebo.period = placebo.period.boot, + placebo.period = placebo.period.boot, placeboTest = placeboTest, carryoverTest = carryoverTest, carryover.period = carryover.period.boot, group.level = group.level, group = boot.group, time.on.seq.group = group.time.on, - time.off.seq.group = group.time.off), silent = TRUE) + time.off.seq.group = group.time.off, + HTEid = HTEid, + moderator.type = moderator.type, + moderator.nbins = moderator.nbins, + #HTEbootVal = bootVal + ), silent = TRUE) } else if (method == "mc") { boot <- try(fect.mc(Y = Y[,boot.id], X = X.boot, D = D[,boot.id], W = W.boot, I = I[,boot.id], II = II[,boot.id], - T.on = T.on[,boot.id], T.off = T.off.boot, + T.on = T.on[,boot.id], T.off = T.off.boot, T.on.carry = T.on.carry[, boot.id], T.on.balance = T.on.balance[, boot.id], balance.period = balance.period, - lambda.cv = out$lambda.cv, force = force, - hasF = out$validF, hasRevs = hasRevs, + lambda.cv = out$lambda.cv, force = force, + hasF = out$validF, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 1, norm.para = norm.para, calendar.enp.seq = target.enp, - time.on.seq = time.on, + #HTE.enp.seq = HTE.enp, + time.on.seq = time.on, time.off.seq = time.off, time.on.seq.W = time.on.W, time.off.seq.W = time.off.W, time.on.carry.seq = carry.time, time.on.balance.seq = balance.time, - placebo.period = placebo.period.boot, + placebo.period = placebo.period.boot, placeboTest = placeboTest, carryoverTest = carryoverTest, carryover.period = carryover.period.boot, @@ -1017,29 +1106,30 @@ fect.boot <- function(Y, time.off.seq.group = group.time.off), silent = TRUE) } else if (method %in% c("polynomial", "bspline", "cfe")) { - + boot <- try(fect.polynomial(Y = Y[,boot.id], X = X.boot, W = W.boot, D = D[,boot.id], I = I[,boot.id], II = II[,boot.id], - T.on = T.on[,boot.id], T.off = T.off.boot, + T.on = T.on[,boot.id], T.off = T.off.boot, T.on.carry = T.on.carry[, boot.id], T.on.balance = T.on.balance[, boot.id], balance.period = balance.period, - method = method, degree = degree, + method = method, degree = degree, sfe = sfe, cfe = cfe, ind.matrix = ind.matrix.boot, knots = knots, force = force, hasRevs = hasRevs, tol = tol, max.iteration = max.iteration, boot = 1, - norm.para = norm.para, - time.on.seq = time.on, + norm.para = norm.para, + time.on.seq = time.on, calendar.enp.seq = target.enp, + #HTE.enp.seq = HTE.enp, time.off.seq = time.off, time.on.seq.W = time.on.W, time.off.seq.W = time.off.W, time.on.carry.seq = carry.time, time.on.balance.seq = balance.time, - placebo.period = placebo.period.boot, + placebo.period = placebo.period.boot, carryoverTest = carryoverTest, carryover.period = carryover.period.boot, placeboTest = placeboTest, @@ -1047,18 +1137,18 @@ fect.boot <- function(Y, group = boot.group, time.on.seq.group = group.time.on, time.off.seq.group = group.time.off),silent = TRUE) - - + + } if ('try-error' %in% class(boot)) { - boot0 <- list(att.avg = NA, att = NA, count = NA, - beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, + boot0 <- list(att.avg = NA, att = NA, count = NA, + beta = NA, att.off = NA, count.off = NA, eff.calendar = NA, eff.calendar.fit = NA, att.placebo = NA, att.avg.unit = NA, att.carryover = NA, group.att = NA, marginal = NA,carry.att = NA, group.output = list(), - balance.att = NA, balance.att.placebo = NA, balance.count = NA, + balance.att = NA, balance.att.placebo = NA, balance.count = NA, balance.avg.att = NA, balance.time = NA, att.avg.W = NA, att.on.W = NA, count.on.W = NA, time.on.W = NA, att.placebo.W = NA, att.off.W = NA, count.off.W = NA, time.off.W = NA, att.carryover.W = NA) @@ -1066,23 +1156,23 @@ fect.boot <- function(Y, } else { return(boot) } - } + } } - } - - + } + + ## jack.seq <- sample(1:N, N, replace = FALSE) boot.seq <- NULL if (vartype == "jackknife") { ## nboots <- min(N, nboots) ## boot.seq <- jack.seq[1:nboots] - boot.seq <- 1:N + boot.seq <- 1:N } ## computing - if (parallel == TRUE) { - boot.out <- foreach(j=1:nboots, + if (parallel == TRUE) { + boot.out <- foreach(j=1:nboots, .inorder = FALSE, .export = c("fect.fe", "fect.mc", "fect.polynomial", "get_term","fect.gsynth","initialFit"), .packages = c("fect","mvtnorm","fixest") @@ -1090,14 +1180,44 @@ fect.boot <- function(Y, return(one.nonpara(boot.seq[j])) } - for (j in 1:nboots) { + for (j in 1:nboots) { + att.avg.boot[,j] <- boot.out[[j]]$att.avg att.avg.unit.boot[, j] <- boot.out[[j]]$att.avg.unit att.boot[,j] <- boot.out[[j]]$att + eff.boot[,,j] <- boot.out[[j]]$eff + + # for (i in c(1:length(att.HTE))){ + # time.temp <- c(boot.out[[j]]$time.HTE[[i]]) + # index.temp <- which(c(time.HTE[[i]]) %in% time.temp) + # att.HTE.boot[[i]][index.temp,j] <- boot.out[[j]]$att.HTE[index.temp] + # } + att.count.boot[,j] <- boot.out[[j]]$count - calendar.eff.boot[,j] <- boot.out[[j]]$eff.calendar calendar.eff.fit.boot[,j] <- boot.out[[j]]$eff.calendar.fit + + if (length(HTEid) == 1){ + avg.HTE.boot[,j] = boot.out[[j]]$avg.HTE + avg.HTE.fit.boot[,j] <- boot.out[[j]]$avg.HTE.fit + + for (k in c(1:length(att.boot.HTE))){ + temp.att.HTE.med <- rep(NA,length(out$att.HTE[[k]])) + temp.timeseq <- out$time.HTE[[k]] + temp.time.HTE <- boot.out[[j]]$time.HTE[[k]] + temp.att.HTE.med[which(temp.timeseq %in% temp.time.HTE)] <- boot.out[[j]]$att.HTE[[k]] + att.boot.HTE[[k]][,j] = temp.att.HTE.med + } + } + + # if(length(HTEid) == 1){ + # HTE.eff.boot[,j] <- boot.out[[j]]$eff.HTE + # if(moderator.type == "continuous"){ + # HTE.eff.fit.boot[,j] <- boot.out[[j]]$eff.HTE.fit + # } + # HTEcoef.boot[,j] <- boot.out[[j]]$HTEcoef + # } + if (p > 0) { beta.boot[,j] <- boot.out[[j]]$beta if (binary == TRUE) { @@ -1106,7 +1226,7 @@ fect.boot <- function(Y, } if (hasRevs == 1) { att.off.boot[,j] <- boot.out[[j]]$att.off - att.off.count.boot[,j] <- boot.out[[j]]$count.off + att.off.count.boot[,j] <- boot.out[[j]]$count.off } if (!is.null(T.on.carry)) { carry.att.boot[,j] <- boot.out[[j]]$carry.att @@ -1142,7 +1262,7 @@ fect.boot <- function(Y, att.carryover.boot[,j] <- boot.out[[j]]$att.carryover } if (!is.null(group)) { - group.att.boot[,j] <- boot.out[[j]]$group.att + group.att.boot[,j] <- boot.out[[j]]$group.att for(sub.name in group.output.name){ if(is.null(boot.out[[j]]$group.output[[sub.name]]$att.on)){ group.atts.boot[[sub.name]][,j] <- NA @@ -1170,34 +1290,62 @@ fect.boot <- function(Y, group.att.carryover.boot[[sub.name]][,j] <- boot.out[[j]]$group.output[[sub.name]]$att.carryover } } - } + } } - } - } + } + } else { - pb <- txtProgressBar(min = 0, - max = nboots, - style = 3, - width = 50, + pb <- txtProgressBar(min = 0, + max = nboots, + style = 3, + width = 50, char = "=") - for (j in 1:nboots) { - boot <- one.nonpara(boot.seq[j]) + for (j in 1:nboots) { + boot <- one.nonpara(boot.seq[j]) att.avg.boot[,j] <- boot$att.avg att.avg.unit.boot[,j] <- boot$att.avg.unit att.boot[,j] <- boot$att + eff.boot[,,j] >- boot.out[[j]]$eff att.count.boot[,j] <- boot$count + + + # for (i in c(1:length(att.HTE))){ + # time.temp <- c(boot$time.HTE[[i]]) + # index.temp <- which(c(time.HTE[[i]]) %in% time.temp) + # att.HTE.boot[[i]][index.temp,j] <- boot$att.HTE[index.temp] + # } + calendar.eff.boot[,j] <- boot$eff.calendar calendar.eff.fit.boot[,j] <- boot$eff.calendar.fit + if(length(HTEid) == 1){ + avg.HTE.boot[,j] = boot.out[[j]]$avg.HTE + avg.HTE.fit.boot[,j] <- boot.out[[j]]$avg.HTE.fit + + for (k in c(1:length(att.boot.HTE))){ + temp.att.HTE.med <- rep(NA,length(out$att.HTE[[k]])) + temp.timeseq <- out$time.HTE[[k]] + temp.time.HTE <- boot.out[[j]]$time.HTE[[k]] + temp.att.HTE.med[which(temp.timeseq %in% temp.time.HTE)] <- boot.out[[j]]$att.HTE[[k]] + att.boot.HTE[[k]][,j] = temp.att.HTE.med + } + #if(moderator.type == "continuous"){ + #HTE.eff.fit.boot[,j] <- boot$eff.HTE.fit + #} + # HTEcoef.boot[,j] <- boot$HTEcoef + } + + + if (p > 0) { beta.boot[,j] <- boot$beta if (binary == TRUE) { - marginal.boot[,j] <- boot$marginal + marginal.boot[,j] <- boot$marginal } } if (hasRevs == 1) { att.off.boot[,j] <- boot$att.off - att.off.count.boot[,j] <- boot$count.off + att.off.count.boot[,j] <- boot$count.off } if (!is.null(T.on.carry)) { carry.att.boot[,j] <- boot$carry.att @@ -1232,7 +1380,7 @@ fect.boot <- function(Y, att.carryover.boot[,j] <- boot$att.carryover } if (!is.null(group)) { - group.att.boot[,j] <- boot$group.att + group.att.boot[,j] <- boot$group.att for(sub.name in group.output.name){ if(is.null(boot$group.output[[sub.name]]$att.on)){ group.atts.boot[[sub.name]][,j] <- NA @@ -1260,12 +1408,12 @@ fect.boot <- function(Y, group.att.carryover.boot[[sub.name]][,j] <- boot$group.output[[sub.name]]$att.carryover } } - } + } } - setTxtProgressBar(pb, j) + setTxtProgressBar(pb, j) } - close(pb) - } + close(pb) + } ## end of bootstrapping ## remove failure bootstrap @@ -1278,6 +1426,18 @@ fect.boot <- function(Y, att.count.boot <- as.matrix(att.count.boot[,-boot.rm]) calendar.eff.boot <- as.matrix(calendar.eff.boot[,-boot.rm]) calendar.eff.fit.boot <- as.matrix(calendar.eff.fit.boot[,-boot.rm]) + if(length(HTEid) == 1){ + HTE.eff.boot <- as.matrix(HTE.eff.boot[,-boot.rm]) + if(moderator.type == "continuous"){ + HTE.eff.fit.boot <- as.matrix(HTE.eff.fit.boot[,-boot.rm]) + } + # HTEcoef.boot <- as.matrix(HTEcoef.boot[,-boot.rm]) + } + + # for (i in c(1:length(att.HTE))){ + # att.HTE.boot[[i]] <- as.matrix(att.HTE.boot[[i]][,-boot.rm]) + # } + if (p > 0) { beta.boot <- as.matrix(beta.boot[,-boot.rm]) if (dim(beta.boot)[2] == 1) { @@ -1338,7 +1498,7 @@ fect.boot <- function(Y, if(carryoverTest){ group.att.carryover.boot[[sub.name]] <- t(as.matrix(group.att.carryover.boot[[sub.name]][,-boot.rm])) } - } + } } } if (dis) { @@ -1358,23 +1518,24 @@ fect.boot <- function(Y, pos <- c(which(nan.pos),which(na.pos)) vec.a <- vec[-pos] a <- sum(vec.a >= 0)/(length(vec)-sum(nan.pos|na.pos)) * 2 - b <- sum(vec.a <= 0)/(length(vec)-sum(nan.pos|na.pos)) * 2 + b <- sum(vec.a <= 0)/(length(vec)-sum(nan.pos|na.pos)) * 2 } else { a <- sum(vec >= 0)/length(vec) * 2 - b <- sum(vec <= 0)/length(vec) * 2 + b <- sum(vec <= 0)/length(vec) * 2 } return(min(as.numeric(min(a, b)),1)) } ## ATT estimates if (vartype == "jackknife") { - + att.j <- jackknifed(att, att.boot, alpha, quantile.CI = quantile.CI) est.att <- cbind(att, att.j$se, att.j$CI.l, att.j$CI.u, att.j$P, out$count) colnames(est.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(est.att) <- out$time - vcov.att <- att.j$vcov + + att.bound <- cbind(att + qnorm(alpha)*att.j$se, att + qnorm(1 - alpha)*att.j$se) colnames(att.bound) <- c("CI.lower", "CI.upper") @@ -1387,14 +1548,48 @@ fect.boot <- function(Y, eff.calendar.fit.j <- jackknifed(calendar.eff.fit, calendar.eff.fit.boot, alpha, quantile.CI = quantile.CI) est.eff.calendar.fit <- cbind(calendar.eff.fit, eff.calendar.fit.j$se, eff.calendar.fit.j$CI.l, eff.calendar.fit.j$CI.u, eff.calendar.fit.j$P, calendar.N) colnames(est.eff.calendar.fit) <- c("ATT-calendar Fitted", "S.E.", "CI.lower", "CI.upper","p.value", "count") + if(length(HTEid) == 1){ + avg.HTE.j <- jackknifed(avg.HTE,avg.HTE.boot,alpha,quantile.CI = quantile.CI) + est.avg.HTE <- cbind(avg.HTE, avg.HTE.j$se, avg.HTE.j$CI.l, avg.HTE.j$CI.u, avg.HTE.j$P, out$N.HTE) + colnames(est.avg.HTE) <- c("AVG", "S.E.", "CI.lower", "CI.upper", + "p.value", "count") + rownames(est.avg.HTE) <- out$Val.HTE + est.att.HTE <- list() + for (i in c(1:length(att.boot.HTE))){ + temp.att.j <- jackknifed(att, att.boot.HTE[[i]], alpha, quantile.CI = quantile.CI) + est.att.HTE[[i]] <- cbind(out$att.HTE[[i]],temp.att.j$se,temp.att.j$CI.l,temp.att.j$CI.u,temp.att.j$P,out$count.HTE[[i]]) + colnames(est.att.HTE[[i]]) <- c("ATT", "S.E.", "CI.lower", "CI.upper", + "p.value", "count") + rownames(est.att.HTE[[i]]) <- out$time.HTE[[i]] + } + + avg.HTE.fit.j <- jackknifed(avg.HTE.fit,avg.HTE.fit.boot,alpha,quantile.CI = quantile.CI) + est.avg.HTE.fit <- cbind(avg.HTE.fit, avg.HTE.fit.j$se, avg.HTE.fit.j$CI.l, avg.HTE.fit.j$CI.u, avg.HTE.fit.j$P, out$N.HTE) + colnames(est.avg.HTE.fit) <- c("AVG", "S.E.", "CI.lower", "CI.upper", + "p.value", "count") + rownames(est.avg.HTE.fit) <- out$Val.HTE + } + + # if(length(HTEid) == 1){ + # eff.HTE.j <- jackknifed(HTE.eff, HTE.eff.boot, alpha, quantile.CI = quantile.CI) + # est.eff.HTE <- cbind(HTE.eff, eff.HTE.j$se, eff.HTE.j$CI.l, eff.HTE.j$CI.u, eff.HTE.j$P, HTE.N) + # colnames(est.eff.HTE) <- c("ATT-HTE", "S.E.", "CI.lower", "CI.upper","p.value", "count") + # if(moderator.type == "continuous"){ + # eff.HTE.fit.j <- jackknifed(HTE.eff.fit, HTE.eff.fit.boot, alpha, quantile.CI = quantile.CI) + # est.eff.HTE.fit <- cbind(HTE.eff.fit, eff.HTE.fit.j$se, eff.HTE.fit.j$CI.l, eff.HTE.fit.j$CI.u, eff.HTE.fit.j$P, HTE.N) + # colnames(est.eff.HTE.fit) <- c("ATT-HTE Fitted", "S.E.", "CI.lower", "CI.upper","p.value", "count") + # } + # else{ + # est.eff.HTE.fit <- NULL + # } + # } if (hasRevs == 1) { att.off.j <- jackknifed(att.off, att.off.boot, alpha, quantile.CI = quantile.CI) est.att.off <- cbind(att.off, att.off.j$se, att.off.j$CI.l, att.off.j$CI.u, att.off.j$P, out$count.off) colnames(est.att.off) <- c("ATT.OFF", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(est.att.off) <- out$time.off - vcov.att.off <- att.off.j$vcov att.off.bound <- cbind(att.off + qnorm(alpha)*att.off.j$se, att.off + qnorm(1 - alpha)*att.off.j$se) colnames(att.off.bound) <- c("CI.lower", "CI.upper") @@ -1403,7 +1598,7 @@ fect.boot <- function(Y, if (!is.null(T.on.carry)) { carry.att.j <- jackknifed(carry.att, carry.att.boot, alpha, quantile.CI = quantile.CI) - est.carry.att <- cbind(carry.att, carry.att.j$se, + est.carry.att <- cbind(carry.att, carry.att.j$se, carry.att.j$CI.l, carry.att.j$CI.u, carry.att.j$P) colnames(est.carry.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", @@ -1417,8 +1612,6 @@ fect.boot <- function(Y, colnames(est.balance.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(est.balance.att) <- out$balance.time - vcov.balance.att <- balance.att.j$vcov - balance.avg.att.j <- jackknifed(balance.avg.att, balance.avg.att.boot, alpha, quantile.CI = quantile.CI) est.balance.avg <- t(as.matrix(c(balance.avg.att, balance.avg.att.j$se, balance.avg.att.j$CI.l, balance.avg.att.j$CI.u, balance.avg.att.j$P))) @@ -1432,7 +1625,7 @@ fect.boot <- function(Y, balance.att.placebo.j <- jackknifed(balance.att.placebo, balance.att.placebo.boot, alpha, quantile.CI = quantile.CI) est.balance.placebo <- t(as.matrix(c(balance.att.placebo, balance.att.placebo.j$se, balance.att.placebo.j$CI.l, balance.att.placebo.j$CI.u, balance.att.placebo.j$P))) colnames(est.balance.placebo) <- c("ATT.placebo", "S.E.", "CI.lower", "CI.upper", "p.value") - } + } } if (!is.null(W)){ @@ -1445,8 +1638,6 @@ fect.boot <- function(Y, colnames(est.att.W) <- c("ATT", "S.E.", "CI.lower", "CI.upper","p.value", "count") rownames(est.att.W) <- time.on.W - vcov.att.W <- att.on.W.j$vcov - att.W.bound <- cbind(att.on.W + qnorm(alpha)*att.on.W.j$se, att.on.W + qnorm(1 - alpha)*att.on.W.j$se) colnames(att.W.bound) <- c("CI.lower", "CI.upper") rownames(att.W.bound) <- time.on.W @@ -1461,7 +1652,7 @@ fect.boot <- function(Y, est.att.off.W <- cbind(att.off.W, att.off.W.j$se, att.off.W.j$CI.l, att.off.W.j$CI.u, att.off.W.j$P, count.off.W) colnames(est.att.off.W) <- c("ATT", "S.E.", "CI.lower", "CI.upper","p.value", "count") rownames(est.att.off.W) <- time.off.W - vcov.att.off.W <- att.off.W.j$vcov + att.off.W.bound <- cbind(att.off.W + qnorm(alpha)*att.off.W.j$se, att.off.W + qnorm(1 - alpha)*att.off.W.j$se) colnames(att.off.W.bound) <- c("CI.lower", "CI.upper") rownames(att.off.W.bound) <- out$time.off @@ -1500,14 +1691,14 @@ fect.boot <- function(Y, if (!is.null(placebo.period) & placeboTest == TRUE) { att.placebo <- out$att.placebo att.placebo.j <- jackknifed(att.placebo, att.placebo.boot, alpha, quantile.CI = quantile.CI) - att.placebo.bound <- c(att.placebo + qnorm(alpha)*att.placebo.j$se, + att.placebo.bound <- c(att.placebo + qnorm(alpha)*att.placebo.j$se, att.placebo + qnorm(1 - alpha)*att.placebo.j$se) - est.placebo <- t(as.matrix(c(att.placebo, att.placebo.j$se, - att.placebo.j$CI.l, att.placebo.j$CI.u, + est.placebo <- t(as.matrix(c(att.placebo, att.placebo.j$se, + att.placebo.j$CI.l, att.placebo.j$CI.u, att.placebo.j$P, att.placebo.bound))) - colnames(est.placebo) <- c("ATT.placebo", "S.E.", - "CI.lower", "CI.upper", + colnames(est.placebo) <- c("ATT.placebo", "S.E.", + "CI.lower", "CI.upper", "p.value", "CI.lower(90%)","CI.upper(90%)") } @@ -1515,15 +1706,15 @@ fect.boot <- function(Y, if (!is.null(carryover.period) & carryoverTest == TRUE) { att.carryover <- out$att.carryover att.carryover.j <- jackknifed(att.carryover, att.carryover.boot, alpha, quantile.CI = quantile.CI) - att.carryover.bound <- c(att.carryover + qnorm(alpha)*att.carryover.j$se, + att.carryover.bound <- c(att.carryover + qnorm(alpha)*att.carryover.j$se, att.carryover + qnorm(1 - alpha)*att.carryover.j$se) - - est.carryover <- t(as.matrix(c(att.carryover, att.carryover.j$se, - att.carryover.j$CI.l, att.carryover.j$CI.u, + + est.carryover <- t(as.matrix(c(att.carryover, att.carryover.j$se, + att.carryover.j$CI.l, att.carryover.j$CI.u, att.carryover.j$P, att.carryover.bound))) - colnames(est.carryover) <- c("ATT.carryover", "S.E.", - "CI.lower", "CI.upper", + colnames(est.carryover) <- c("ATT.carryover", "S.E.", + "CI.lower", "CI.upper", "p.value", "CI.lower(90%)","CI.upper(90%)") } @@ -1534,29 +1725,29 @@ fect.boot <- function(Y, est.group.att <- cbind(group.att, group.att.j$se, group.att.j$CI.l, group.att.j$CI.u, group.att.j$P) colnames(est.group.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value") - + est.group.out <- list() for(sub.name in group.output.name){ subgroup.atts <- group.output.origin[[sub.name]]$att.on subgroup.atts.boot <- group.atts.boot[[sub.name]] subgroup.est.att <- NULL subgroup.att.bound <- NULL - + if(dim(subgroup.atts.boot)[1]>0){ subgroup.att.j <- jackknifed(subgroup.atts, subgroup.atts.boot, alpha, quantile.CI = quantile.CI) - subgroup.est.att <- cbind(subgroup.atts, subgroup.att.j$se, subgroup.att.j$CI.l, - subgroup.att.j$CI.u, subgroup.att.j$P, + subgroup.est.att <- cbind(subgroup.atts, subgroup.att.j$se, subgroup.att.j$CI.l, + subgroup.att.j$CI.u, subgroup.att.j$P, group.output.origin[[sub.name]]$count.on) colnames(subgroup.est.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(subgroup.est.att) <- group.output.origin[[sub.name]]$time.on - - subgroup.att.bound <- cbind(subgroup.atts + qnorm(alpha)*subgroup.att.j$se, + + subgroup.att.bound <- cbind(subgroup.atts + qnorm(alpha)*subgroup.att.j$se, subgroup.atts + qnorm(1 - alpha)*subgroup.att.j$se) colnames(subgroup.att.bound) <- c("CI.lower", "CI.upper") rownames(subgroup.att.bound) <- group.output.origin[[sub.name]]$time.on } - + subgroup.est.att.off <- NULL subgroup.att.off.bound <- NULL if(hasRevs == 1){ @@ -1564,17 +1755,17 @@ fect.boot <- function(Y, subgroup.atts.off.boot <- group.atts.off.boot[[sub.name]] if(dim(subgroup.atts.off.boot)[1]>0){ subgroup.att.off.j <- jackknifed(subgroup.atts.off, subgroup.atts.off.boot, alpha, quantile.CI = quantile.CI) - subgroup.est.att.off <- cbind(subgroup.atts.off, subgroup.att.off.j$se, subgroup.att.off.j$CI.l, - subgroup.att.off.j$CI.u, subgroup.att.off.j$P, + subgroup.est.att.off <- cbind(subgroup.atts.off, subgroup.att.off.j$se, subgroup.att.off.j$CI.l, + subgroup.att.off.j$CI.u, subgroup.att.off.j$P, group.output.origin[[sub.name]]$count.off) colnames(subgroup.est.att.off) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(subgroup.est.att.off) <- group.output.origin[[sub.name]]$time.off - - subgroup.att.off.bound <- cbind(subgroup.atts.off + qnorm(alpha)*subgroup.att.off.j$se, + + subgroup.att.off.bound <- cbind(subgroup.atts.off + qnorm(alpha)*subgroup.att.off.j$se, subgroup.atts.off + qnorm(1 - alpha)*subgroup.att.off.j$se) colnames(subgroup.att.off.bound) <- c("CI.lower", "CI.upper") - rownames(subgroup.att.off.bound) <- group.output.origin[[sub.name]]$time.off + rownames(subgroup.att.off.bound) <- group.output.origin[[sub.name]]$time.off } } @@ -1583,19 +1774,19 @@ fect.boot <- function(Y, subgroup.att.placebo <- group.output.origin[[sub.name]]$att.placebo if(length(subgroup.att.placebo)>0){ subgroup.att.placebo.j <- jackknifed(subgroup.att.placebo, group.att.placebo.boot[[sub.name]], alpha, quantile.CI = quantile.CI) - att.placebo.bound <- c(subgroup.att.placebo + qnorm(alpha)*subgroup.att.placebo.j$se, + att.placebo.bound <- c(subgroup.att.placebo + qnorm(alpha)*subgroup.att.placebo.j$se, subgroup.att.placebo + qnorm(1 - alpha)*subgroup.att.placebo.j$se) - - subgroup.est.placebo <- t(as.matrix(c(subgroup.att.placebo, - subgroup.att.placebo.j$se, - subgroup.att.placebo.j$CI.l, - subgroup.att.placebo.j$CI.u, + + subgroup.est.placebo <- t(as.matrix(c(subgroup.att.placebo, + subgroup.att.placebo.j$se, + subgroup.att.placebo.j$CI.l, + subgroup.att.placebo.j$CI.u, subgroup.att.placebo.j$P, att.placebo.bound))) - colnames(subgroup.est.placebo) <- c("ATT.placebo", "S.E.", + colnames(subgroup.est.placebo) <- c("ATT.placebo", "S.E.", "CI.lower", "CI.upper", "p.value", "CI.lower(90%)","CI.upper(90%)") - + } } @@ -1604,19 +1795,19 @@ fect.boot <- function(Y, subgroup.att.carryover <- group.output.origin[[sub.name]]$att.carryover if(length(subgroup.att.carryover)>0){ subgroup.att.carryover.j <- jackknifed(subgroup.att.carryover, group.att.carryover.boot[[sub.name]], alpha, quantile.CI = quantile.CI) - att.carryover.bound <- c(subgroup.att.carryover + qnorm(alpha)*subgroup.att.carryover.j$se, + att.carryover.bound <- c(subgroup.att.carryover + qnorm(alpha)*subgroup.att.carryover.j$se, subgroup.att.carryover + qnorm(1 - alpha)*subgroup.att.carryover.j$se) - - subgroup.est.carryover <- t(as.matrix(c(subgroup.att.carryover, - subgroup.att.carryover.j$se, - subgroup.att.carryover.j$CI.l, - subgroup.att.carryover.j$CI.u, + + subgroup.est.carryover <- t(as.matrix(c(subgroup.att.carryover, + subgroup.att.carryover.j$se, + subgroup.att.carryover.j$CI.l, + subgroup.att.carryover.j$CI.u, subgroup.att.carryover.j$P, att.carryover.bound))) - colnames(subgroup.est.carryover) <- c("ATT.carryover", "S.E.", + colnames(subgroup.est.carryover) <- c("ATT.carryover", "S.E.", "CI.lower", "CI.upper", "p.value", "CI.lower(90%)","CI.upper(90%)") - + } } @@ -1630,7 +1821,7 @@ fect.boot <- function(Y, att.carryover = subgroup.est.carryover) } } - } + } else { se.att <- apply(att.boot, 1, function(vec) sd(vec, na.rm=TRUE)) @@ -1643,13 +1834,61 @@ fect.boot <- function(Y, pvalue.att <- apply(att.boot, 1, get.pvalue) } - vcov.att <- cov(t(att.boot), use = "pairwise.complete.obs") - est.att <- cbind(att, se.att, CI.att, pvalue.att, out$count) colnames(est.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(est.att) <- out$time - + + if(length(HTEid) == 1){ + se.avg.HTE <- apply(avg.HTE.boot, 1, function(vec) sd(vec, na.rm=TRUE)) + if(quantile.CI == FALSE){ + CI.avg.HTE <- cbind(avg.HTE - se.avg.HTE * qnorm(1-alpha/2), avg.HTE + se.avg.HTE * qnorm(1-alpha/2)) # normal approximation + pvalue.avg.HTE <- (1-pnorm(abs(avg.HTE/se.avg.HTE)))*2 + } + else{ + CI.avg.HTE <- t(apply(avg.HTE.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + pvalue.avg.HTE <- apply(avg.HTE.boot, 1, get.pvalue) + } + + est.avg.HTE <- cbind(avg.HTE, se.avg.HTE, CI.avg.HTE, pvalue.avg.HTE, out$N.HTE) + colnames(est.avg.HTE) <- c("ATT", "S.E.", "CI.lower", "CI.upper", + "p.value", "count") + rownames(est.avg.HTE) <- out$Val.HTE + + est.att.HTE <- list() + + for (i in c(1:length(out$att.HTE))){ + temp.se.att <- apply(att.boot.HTE[[i]], 1, function(vec) sd(vec, na.rm=TRUE)) + if(quantile.CI == FALSE){ + temp.CI.att <- cbind(out$att.HTE[[i]] - temp.se.att * qnorm(1-alpha/2), out$att.HTE[[i]] + temp.se.att * qnorm(1-alpha/2)) # normal approximation + temp.pvalue.att <- (1-pnorm(abs(out$att.HTE[[i]]/temp.se.att)))*2 + } + else{ + temp.CI.att <- t(apply(att.boot.HTE[[i]], 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + temp.pvalue.att <- apply(att.boot.HTE[[i]], 1, get.pvalue) + } + + est.att.HTE[[i]] <- cbind(out$att.HTE[[i]],temp.se.att,temp.CI.att,temp.pvalue.att,out$count.HTE[[i]]) + } + + se.avg.HTE.fit <- apply(avg.HTE.fit.boot, 1, function(vec) sd(vec, na.rm=TRUE)) + if(quantile.CI == FALSE){ + CI.avg.HTE.fit <- cbind(avg.HTE.fit - se.avg.HTE.fit * qnorm(1-alpha/2), avg.HTE.fit + se.avg.HTE.fit * qnorm(1-alpha/2)) # normal approximation + pvalue.avg.HTE.fit <- (1-pnorm(abs(avg.HTE.fit/se.avg.HTE.fit)))*2 + } + else{ + CI.avg.HTE.fit <- t(apply(avg.HTE.fit.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + pvalue.avg.HTE.fit <- apply(avg.HTE.fit.boot, 1, get.pvalue) + } + + est.avg.HTE.fit <- cbind(avg.HTE.fit, se.avg.HTE.fit, CI.avg.HTE.fit, pvalue.avg.HTE.fit, out$N.HTE) + colnames(est.avg.HTE.fit) <- c("ATT", "S.E.", "CI.lower", "CI.upper", + "p.value", "count") + rownames(est.avg.HTE.fit) <- out$Val.HTE + + } + + # for equivalence test if(quantile.CI == FALSE){ att.bound <- cbind(att - se.att * qnorm(1-alpha), att + se.att * qnorm(1-alpha)) # one-sided @@ -1661,7 +1900,7 @@ fect.boot <- function(Y, rownames(att.bound) <- out$time - + if (hasRevs == 1) { se.att.off <- apply(att.off.boot, 1, function(vec) sd(vec, na.rm=TRUE)) @@ -1670,12 +1909,10 @@ fect.boot <- function(Y, pvalue.att.off <- (1-pnorm(abs(att.off/se.att.off)))*2 } else{ - CI.att.off <- t(apply(att.off.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + CI.att.off <- t(apply(att.off.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) pvalue.att.off <- apply(att.off.boot, 1, get.pvalue) - } + } - vcov.att.off <- cov(t(att.off.boot), use = "pairwise.complete.obs") - est.att.off <- cbind(att.off, se.att.off, CI.att.off, pvalue.att.off, out$count.off) colnames(est.att.off) <- c("ATT.OFF", "S.E.", "CI.lower", "CI.upper", "p.value", "count.off") @@ -1689,7 +1926,7 @@ fect.boot <- function(Y, else{ att.off.bound <- t(apply(att.off.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) } - + colnames(att.off.bound) <- c("CI.lower", "CI.upper") rownames(att.off.bound) <- out$time.off } @@ -1697,17 +1934,17 @@ fect.boot <- function(Y, if (!is.null(T.on.carry)) { se.carry.att <- apply(carry.att.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI ==FALSE){ - CI.carry.att <- cbind(carry.att - se.carry.att * qnorm(1-alpha/2), - carry.att + se.carry.att * qnorm(1-alpha/2)) # normal approximation - pvalue.carry.att <- (1-pnorm(abs(carry.att/se.carry.att)))*2 + CI.carry.att <- cbind(carry.att - se.carry.att * qnorm(1-alpha/2), + carry.att + se.carry.att * qnorm(1-alpha/2)) # normal approximation + pvalue.carry.att <- (1-pnorm(abs(carry.att/se.carry.att)))*2 } else{ - CI.carry.att <- t(apply(carry.att.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + CI.carry.att <- t(apply(carry.att.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) pvalue.carry.att <- apply(carry.att.boot, 1, get.pvalue) } - est.carry.att <- cbind(carry.att, se.carry.att, + est.carry.att <- cbind(carry.att, se.carry.att, CI.carry.att, pvalue.carry.att) colnames(est.carry.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", @@ -1718,26 +1955,24 @@ fect.boot <- function(Y, if(!is.null(balance.period)){ se.balance.att <- apply(balance.att.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI==FALSE){ - CI.balance.att <- cbind(balance.att - se.balance.att * qnorm(1-alpha/2), + CI.balance.att <- cbind(balance.att - se.balance.att * qnorm(1-alpha/2), balance.att + se.balance.att * qnorm(1-alpha/2)) - pvalue.balance.att <- (1-pnorm(abs(balance.att/se.balance.att)))*2 + pvalue.balance.att <- (1-pnorm(abs(balance.att/se.balance.att)))*2 } else{ - CI.balance.att <- t(apply(balance.att.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + CI.balance.att <- t(apply(balance.att.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) pvalue.balance.att <- apply(balance.att.boot, 1, get.pvalue) } - vcov.balance.att <- cov(t(balance.att.boot), use = "pairwise.complete.obs") - - est.balance.att <- cbind(balance.att, se.balance.att, CI.balance.att, + est.balance.att <- cbind(balance.att, se.balance.att, CI.balance.att, pvalue.balance.att, out$balance.count) colnames(est.balance.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(est.balance.att) <- out$balance.time - + se.balance.avg.att <- sd(balance.avg.att.boot, na.rm=TRUE) if(quantile.CI ==FALSE){ - CI.balance.avg.att <- c(balance.avg.att - se.balance.avg.att * qnorm(1-alpha/2), + CI.balance.avg.att <- c(balance.avg.att - se.balance.avg.att * qnorm(1-alpha/2), balance.avg.att + se.balance.avg.att * qnorm(1-alpha/2)) p.balance.avg.att <- (1-pnorm(abs(balance.avg.att/se.balance.avg.att)))*2 } @@ -1745,29 +1980,29 @@ fect.boot <- function(Y, CI.balance.avg.att <- quantile(balance.avg.att.boot,c(alpha/2, 1 - alpha/2), na.rm=TRUE) p.balance.avg.att <- get.pvalue(balance.avg.att.boot) } - + est.balance.avg <- t(as.matrix(c(balance.avg.att, se.balance.avg.att, CI.balance.avg.att, p.balance.avg.att))) colnames(est.balance.avg) <- c("ATT.avg", "S.E.", "CI.lower", "CI.upper", "p.value") if(quantile.CI ==FALSE){ - balance.att.bound <- cbind(balance.att - se.balance.att * qnorm(1-alpha), + balance.att.bound <- cbind(balance.att - se.balance.att * qnorm(1-alpha), balance.att + se.balance.att * qnorm(1-alpha)) } else{ balance.att.bound <- t(apply(balance.att.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) } - + colnames(balance.att.bound) <- c("CI.lower", "CI.upper") rownames(balance.att.bound) <- out$balance.time if (!is.null(placebo.period) & placeboTest == TRUE) { - balance.att.placebo <- out$balance.att.placebo + balance.att.placebo <- out$balance.att.placebo balance.se.placebo <- sd(balance.att.placebo.boot, na.rm=TRUE) if(quantile.CI==FALSE){ - balance.CI.placebo <- c(balance.att.placebo - balance.se.placebo * qnorm(1-alpha/2), + balance.CI.placebo <- c(balance.att.placebo - balance.se.placebo * qnorm(1-alpha/2), balance.att.placebo + balance.se.placebo * qnorm(1-alpha/2)) - balance.CI.placebo.bound <- c(balance.att.placebo - balance.se.placebo * qnorm(1-alpha), + balance.CI.placebo.bound <- c(balance.att.placebo - balance.se.placebo * qnorm(1-alpha), balance.att.placebo + balance.se.placebo * qnorm(1-alpha)) - balance.pvalue.placebo <- (1-pnorm(abs(balance.att.placebo/balance.se.placebo)))*2 + balance.pvalue.placebo <- (1-pnorm(abs(balance.att.placebo/balance.se.placebo)))*2 } else{ balance.CI.placebo <- quantile(balance.att.placebo.boot,c(alpha/2, 1 - alpha/2), na.rm=TRUE) @@ -1775,13 +2010,13 @@ fect.boot <- function(Y, balance.pvalue.placebo <- get.pvalue(balance.att.placebo.boot) } - - est.balance.placebo <- t(as.matrix(c(balance.att.placebo, - balance.se.placebo, - balance.CI.placebo, + + est.balance.placebo <- t(as.matrix(c(balance.att.placebo, + balance.se.placebo, + balance.CI.placebo, balance.pvalue.placebo, balance.CI.placebo.bound))) - colnames(est.balance.placebo) <- c("ATT.placebo", "S.E.", + colnames(est.balance.placebo) <- c("ATT.placebo", "S.E.", "CI.lower", "CI.upper", "p.value", "CI.lower(90%)", "CI.upper(90%)") } @@ -1791,54 +2026,52 @@ fect.boot <- function(Y, #att.avg.W.boot se.att.avg.W <- sd(att.avg.W.boot, na.rm=TRUE) if(quantile.CI == FALSE){ - CI.att.avg.W <- c(att.avg.W - se.att.avg.W * qnorm(1-alpha/2), + CI.att.avg.W <- c(att.avg.W - se.att.avg.W * qnorm(1-alpha/2), att.avg.W + se.att.avg.W * qnorm(1-alpha/2)) - p.att.avg.W <- (1-pnorm(abs(att.avg.W/se.att.avg.W)))*2 + p.att.avg.W <- (1-pnorm(abs(att.avg.W/se.att.avg.W)))*2 } else{ CI.att.avg.W <- quantile(att.avg.W.boot,c(alpha/2, 1 - alpha/2), na.rm=TRUE) p.att.avg.W <- get.pvalue(att.avg.W.boot) } - + est.avg.W <- t(as.matrix(c(att.avg.W, se.att.avg.W, CI.att.avg.W, p.att.avg.W))) colnames(est.avg.W) <- c("ATT.avg", "S.E.", "CI.lower", "CI.upper", "p.value") #att.on.W.boot se.att.W <- apply(att.on.W.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI == FALSE){ - CI.att.W <- cbind(att.on.W - se.att.W * qnorm(1-alpha/2), + CI.att.W <- cbind(att.on.W - se.att.W * qnorm(1-alpha/2), att.on.W + se.att.W * qnorm(1-alpha/2)) - att.W.bound <- cbind(att.on.W - se.att.W * qnorm(1-alpha), + att.W.bound <- cbind(att.on.W - se.att.W * qnorm(1-alpha), att.on.W + se.att.W * qnorm(1-alpha)) - pvalue.att.W <- (1-pnorm(abs(att.on.W/se.att.W)))*2 + pvalue.att.W <- (1-pnorm(abs(att.on.W/se.att.W)))*2 } else{ CI.att.W <- t(apply(att.on.W.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) - att.W.bound <- t(apply(att.on.W.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) - pvalue.att.W <- apply(att.on.W.boot, 1, get.pvalue) + att.W.bound <- t(apply(att.on.W.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) + pvalue.att.W <- apply(att.on.W.boot, 1, get.pvalue) } - vcov.att.W <- cov(t(att.on.W.boot), use = "pairwise.complete.obs") - - est.att.W <- cbind(att.on.W, se.att.W, CI.att.W, + est.att.W <- cbind(att.on.W, se.att.W, CI.att.W, pvalue.att.W, count.on.W) colnames(est.att.W) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(est.att.W) <- time.on.W - + colnames(att.W.bound) <- c("CI.lower", "CI.upper") rownames(att.W.bound) <- time.on.W - + if (!is.null(placebo.period) & placeboTest == TRUE) { # att.placebo.W.boot se.placebo.W <- sd(att.placebo.W.boot, na.rm=TRUE) if(quantile.CI == FALSE){ - CI.placebo.W <- c(att.placebo.W - se.placebo.W * qnorm(1-alpha/2), + CI.placebo.W <- c(att.placebo.W - se.placebo.W * qnorm(1-alpha/2), att.placebo.W + se.placebo.W * qnorm(1-alpha/2)) - CI.placebo.bound.W <- c(att.placebo.W - se.placebo.W * qnorm(1-alpha), + CI.placebo.bound.W <- c(att.placebo.W - se.placebo.W * qnorm(1-alpha), att.placebo.W + se.placebo.W * qnorm(1-alpha)) - pvalue.placebo.w <- (1-pnorm(abs(att.placebo.W/se.placebo.W)))*2 + pvalue.placebo.w <- (1-pnorm(abs(att.placebo.W/se.placebo.W)))*2 } else{ CI.placebo.W <- quantile(att.placebo.W.boot,c(alpha/2,1-alpha/2), na.rm=TRUE) @@ -1848,12 +2081,12 @@ fect.boot <- function(Y, pvalue.placebo.w <- get.pvalue(att.placebo.W.boot) } - est.placebo.W <- t(as.matrix(c(att.placebo.W, - se.placebo.W, - CI.placebo.W, + est.placebo.W <- t(as.matrix(c(att.placebo.W, + se.placebo.W, + CI.placebo.W, pvalue.placebo.w, CI.placebo.bound.W))) - colnames(est.placebo.W) <- c("ATT.placebo", "S.E.", + colnames(est.placebo.W) <- c("ATT.placebo", "S.E.", "CI.lower", "CI.upper", "p.value", "CI.lower(90%)", "CI.upper(90%)") } @@ -1861,21 +2094,19 @@ fect.boot <- function(Y, # att.off.W.boot se.att.off.W <- apply(att.off.W.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI == FALSE){ - CI.att.off.W <- cbind(att.off.W - se.att.off.W * qnorm(1-alpha/2), + CI.att.off.W <- cbind(att.off.W - se.att.off.W * qnorm(1-alpha/2), att.off.W + se.att.off.W * qnorm(1-alpha/2)) - att.off.W.bound <- cbind(att.off.W - se.att.off.W * qnorm(1-alpha), + att.off.W.bound <- cbind(att.off.W - se.att.off.W * qnorm(1-alpha), att.off.W + se.att.off.W * qnorm(1-alpha)) - pvalue.att.off.W <- (1-pnorm(abs(att.off.W/se.att.off.W)))*2 + pvalue.att.off.W <- (1-pnorm(abs(att.off.W/se.att.off.W)))*2 } else{ CI.att.off.W <- t(apply(att.off.W.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) - att.off.W.bound <- t(apply(att.off.W.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) - pvalue.att.off.W <- apply(att.off.W.boot, 1, get.pvalue) + att.off.W.bound <- t(apply(att.off.W.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) + pvalue.att.off.W <- apply(att.off.W.boot, 1, get.pvalue) } - vcov.att.off.W <- cov(t(att.off.W.boot), use = "pairwise.complete.obs") - - est.att.off.W <- cbind(att.off.W, se.att.off.W, CI.att.off.W, + est.att.off.W <- cbind(att.off.W, se.att.off.W, CI.att.off.W, pvalue.att.off.W, count.off.W) colnames(est.att.off.W) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") @@ -1887,9 +2118,9 @@ fect.boot <- function(Y, # att.carryover.W.boot se.carryover.W <- sd(att.carryover.W.boot, na.rm=TRUE) if(quantile.CI == FALSE){ - CI.carryover.W <- c(att.carryover.W - se.carryover.W * qnorm(1-alpha/2), + CI.carryover.W <- c(att.carryover.W - se.carryover.W * qnorm(1-alpha/2), att.carryover.W + se.carryover.W * qnorm(1-alpha/2)) - CI.carryover.bound.W <- c(att.carryover.W - se.carryover.W * qnorm(1-alpha), + CI.carryover.bound.W <- c(att.carryover.W - se.carryover.W * qnorm(1-alpha), att.carryover.W + se.carryover.W * qnorm(1-alpha)) pvalue.carryover.w <- (1-pnorm(abs(att.carryover.W/se.carryover.W)))*2 } @@ -1899,12 +2130,12 @@ fect.boot <- function(Y, pvalue.carryover.w <- get.pvalue(att.carryover.W.boot) } - est.carryover.W <- t(as.matrix(c(att.carryover.W, - se.carryover.W, - CI.carryover.W, + est.carryover.W <- t(as.matrix(c(att.carryover.W, + se.carryover.W, + CI.carryover.W, pvalue.carryover.w, CI.carryover.bound.W))) - colnames(est.carryover.W) <- c("ATT.carryover", "S.E.", + colnames(est.carryover.W) <- c("ATT.carryover", "S.E.", "CI.lower", "CI.upper", "p.value", "CI.lower(90%)", "CI.upper(90%)") @@ -1916,7 +2147,7 @@ fect.boot <- function(Y, se.avg <- sd(att.avg.boot, na.rm=TRUE) if(quantile.CI == FALSE){ CI.avg <- c(att.avg - se.avg * qnorm(1-alpha/2), att.avg + se.avg * qnorm(1-alpha/2)) - pvalue.avg <- (1-pnorm(abs(att.avg/se.avg)))*2 + pvalue.avg <- (1-pnorm(abs(att.avg/se.avg)))*2 } else{ CI.avg <- quantile(att.avg.boot,c(alpha/2,1-alpha/2), na.rm=TRUE) @@ -1928,9 +2159,9 @@ fect.boot <- function(Y, se.avg.unit <- sd(att.avg.unit.boot, na.rm=TRUE) if(quantile.CI == FALSE){ - CI.avg.unit <- c(att.avg.unit - se.avg.unit * qnorm(1-alpha/2), + CI.avg.unit <- c(att.avg.unit - se.avg.unit * qnorm(1-alpha/2), att.avg.unit + se.avg.unit * qnorm(1-alpha/2)) - pvalue.avg.unit <- (1-pnorm(abs(att.avg.unit/se.avg.unit)))*2 + pvalue.avg.unit <- (1-pnorm(abs(att.avg.unit/se.avg.unit)))*2 } else{ CI.avg.unit <- quantile(att.avg.unit.boot,c(alpha/2,1-alpha/2), na.rm=TRUE) @@ -1939,16 +2170,16 @@ fect.boot <- function(Y, est.avg.unit <- t(as.matrix(c(att.avg.unit, se.avg.unit, CI.avg.unit, pvalue.avg.unit))) colnames(est.avg.unit) <- c("ATT.avg.unit", "S.E.", "CI.lower", "CI.upper", "p.value") - - + + se.eff.calendar <- apply(calendar.eff.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI == FALSE){ CI.eff.calendar <- cbind(calendar.eff - se.eff.calendar * qnorm(1-alpha/2), calendar.eff + se.eff.calendar * qnorm(1-alpha/2)) - pvalue.eff.calendar <- (1-pnorm(abs(calendar.eff/se.eff.calendar)))*2 + pvalue.eff.calendar <- (1-pnorm(abs(calendar.eff/se.eff.calendar)))*2 } else{ CI.eff.calendar <- t(apply(calendar.eff.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) - pvalue.eff.calendar <- apply(calendar.eff.boot, 1, get.pvalue) + pvalue.eff.calendar <- apply(calendar.eff.boot, 1, get.pvalue) } est.eff.calendar <- cbind(calendar.eff, se.eff.calendar, CI.eff.calendar, pvalue.eff.calendar,calendar.N) colnames(est.eff.calendar) <- c("ATT-calendar", "S.E.", "CI.lower", "CI.upper","p.value", "count") @@ -1956,25 +2187,60 @@ fect.boot <- function(Y, se.eff.calendar.fit <- apply(calendar.eff.fit.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI == FALSE){ CI.eff.calendar.fit <- cbind(calendar.eff.fit - se.eff.calendar.fit * qnorm(1-alpha/2), calendar.eff.fit + se.eff.calendar.fit * qnorm(1-alpha/2)) - pvalue.eff.calendar.fit <- (1-pnorm(abs(calendar.eff.fit/se.eff.calendar.fit)))*2 + pvalue.eff.calendar.fit <- (1-pnorm(abs(calendar.eff.fit/se.eff.calendar.fit)))*2 } else{ CI.eff.calendar.fit <- t(apply(calendar.eff.fit.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) - pvalue.eff.calendar.fit <- apply(calendar.eff.fit.boot, 1, get.pvalue) + pvalue.eff.calendar.fit <- apply(calendar.eff.fit.boot, 1, get.pvalue) } est.eff.calendar.fit <- cbind(calendar.eff.fit, se.eff.calendar.fit, CI.eff.calendar.fit, pvalue.eff.calendar.fit,calendar.N) colnames(est.eff.calendar.fit) <- c("ATT-calendar Fitted", "S.E.", "CI.lower", "CI.upper","p.value", "count") + # if(length(HTEid) == 1){ + # se.eff.HTE <- apply(HTE.eff.boot, 1, function(vec) sd(vec, na.rm=TRUE)) + # if(quantile.CI == FALSE){ + # CI.eff.HTE <- cbind(HTE.eff - se.eff.HTE * qnorm(1-alpha/2), HTE.eff + se.eff.HTE * qnorm(1-alpha/2)) + # pvalue.eff.HTE <- (1-pnorm(abs(HTE.eff/se.eff.HTE)))*2 + # } + # else{ + # CI.eff.HTE <- t(apply(HTE.eff.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + # pvalue.eff.HTE <- apply(HTE.eff.boot, 1, get.pvalue) + # } + # est.eff.HTE <- cbind(HTE.eff, se.eff.HTE, CI.eff.HTE, pvalue.eff.HTE,HTE.N) + # colnames(est.eff.HTE) <- c("ATT-HTE", "S.E.", "CI.lower", "CI.upper","p.value", "count") + # if(moderator.type == "continuous"){ + # se.eff.HTE.fit <- apply(HTE.eff.fit.boot, 1, function(vec) sd(vec, na.rm=TRUE)) + # if(quantile.CI == FALSE){ + # CI.eff.HTE.fit <- cbind(HTE.eff.fit - se.eff.HTE.fit * qnorm(1-alpha/2), HTE.eff.fit + se.eff.HTE.fit * qnorm(1-alpha/2)) + # pvalue.eff.HTE.fit <- (1-pnorm(abs(HTE.eff.fit/se.eff.HTE.fit)))*2 + # } + # else{ + # CI.eff.HTE.fit <- t(apply(HTE.eff.fit.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) + # pvalue.eff.HTE.fit <- apply(HTE.eff.fit.boot, 1, get.pvalue) + # } + # est.eff.HTE.fit <- cbind(HTE.eff.fit, se.eff.HTE.fit, CI.eff.HTE.fit, pvalue.eff.HTE.fit,HTE.N) + # colnames(est.eff.HTE.fit) <- c("ATT-HTE Fitted", "S.E.", "CI.lower", "CI.upper","p.value", "count") + # } + # else{ + # est.eff.HTE.fit <- NULL + # } + # # se.HTEcoef <- apply(HTEcoef.boot, 1, function(vec) sd(vec, na.rm=TRUE)) + # # CI.HTEcoef <- cbind(HTEcoef - se.HTEcoef * qnorm(1-alpha/2), HTEcoef + se.HTEcoef * qnorm(1-alpha/2)) + # # pvalue.HTEcoef <- (1-pnorm(abs(HTEcoef/se.HTEcoef)))*2 + # # est.HTEcoef <- cbind(HTEcoef,se.HTEcoef,CI.HTEcoef,pvalue.HTEcoef) + # # colnames(est.HTEcoef) <- c("HTE between Groups", "S.E.", "CI.lower", "CI.upper","p.value") + # } + ## regression coefficents if (p > 0) { se.beta<-apply(beta.boot, 1, function(vec)sd(vec,na.rm=TRUE)) if(quantile.CI == FALSE){ CI.beta <- cbind(c(beta) - se.beta * qnorm(1-alpha/2), c(beta) + se.beta * qnorm(1-alpha/2)) - pvalue.beta <- (1-pnorm(abs(beta/se.beta)))*2 + pvalue.beta <- (1-pnorm(abs(beta/se.beta)))*2 } else{ CI.beta <- t(apply(beta.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) - pvalue.beta <- apply(beta.boot, 1, get.pvalue) + pvalue.beta <- apply(beta.boot, 1, get.pvalue) } est.beta<-cbind(c(beta), se.beta, CI.beta, pvalue.beta) colnames(est.beta)<-c("Coef", "S.E.", "CI.lower", "CI.upper", "p.value") @@ -1982,7 +2248,7 @@ fect.boot <- function(Y, if (binary == TRUE) { out$marginal[na.pos] <- NA se.marginal<-apply(marginal.boot, 1, function(vec)sd(vec,na.rm=TRUE)) - CI.marginal<-cbind(c(out$marginal) - se.marginal * qnorm(1-alpha/2), + CI.marginal<-cbind(c(out$marginal) - se.marginal * qnorm(1-alpha/2), c(out$marginal) + se.marginal * qnorm(1-alpha/2)) pvalue.marginal <- (1-pnorm(abs(out$marginal/se.marginal)))*2 est.marginal<-cbind(out$marginal, se.marginal, CI.marginal, pvalue.marginal) @@ -1992,14 +2258,14 @@ fect.boot <- function(Y, ## placebo test if (!is.null(placebo.period) & placeboTest == TRUE) { - att.placebo <- out$att.placebo + att.placebo <- out$att.placebo se.placebo <- sd(att.placebo.boot, na.rm=TRUE) if(quantile.CI == FALSE){ - CI.placebo <- c(att.placebo - se.placebo * qnorm(1-alpha/2), + CI.placebo <- c(att.placebo - se.placebo * qnorm(1-alpha/2), att.placebo + se.placebo * qnorm(1-alpha/2)) - CI.placebo.bound <- c(att.placebo - se.placebo * qnorm(1-alpha), + CI.placebo.bound <- c(att.placebo - se.placebo * qnorm(1-alpha), att.placebo + se.placebo * qnorm(1-alpha)) - pvalue.placebo <- (1-pnorm(abs(att.placebo/se.placebo)))*2 + pvalue.placebo <- (1-pnorm(abs(att.placebo/se.placebo)))*2 } else{ CI.placebo <- quantile(att.placebo.boot,c(alpha/2,1-alpha/2), na.rm=TRUE) @@ -2007,36 +2273,36 @@ fect.boot <- function(Y, pvalue.placebo <- get.pvalue(att.placebo.boot) } - est.placebo <- t(as.matrix(c(att.placebo, - se.placebo, - CI.placebo, + est.placebo <- t(as.matrix(c(att.placebo, + se.placebo, + CI.placebo, pvalue.placebo, CI.placebo.bound))) - colnames(est.placebo) <- c("ATT.placebo", "S.E.", + colnames(est.placebo) <- c("ATT.placebo", "S.E.", "CI.lower", "CI.upper", "p.value", "CI.lower(90%)", "CI.upper(90%)") } ## carryover test if (!is.null(carryover.period) & carryoverTest == TRUE) { - att.carryover <- out$att.carryover + att.carryover <- out$att.carryover se.carryover <- sd(att.carryover.boot, na.rm=TRUE) if(quantile.CI == FALSE){ - CI.carryover <- c(att.carryover - se.carryover * qnorm(1-alpha/2), + CI.carryover <- c(att.carryover - se.carryover * qnorm(1-alpha/2), att.carryover + se.carryover * qnorm(1-alpha/2)) - CI.carryover.bound <- c(att.carryover - se.carryover * qnorm(1-alpha), + CI.carryover.bound <- c(att.carryover - se.carryover * qnorm(1-alpha), att.carryover + se.carryover * qnorm(1-alpha)) - pvalue.carryover <- (1-pnorm(abs(att.carryover/se.carryover)))*2 + pvalue.carryover <- (1-pnorm(abs(att.carryover/se.carryover)))*2 } else{ CI.carryover <- quantile(att.carryover.boot,c(alpha/2,1-alpha/2), na.rm=TRUE) CI.carryover.bound <- quantile(att.carryover.boot,c(alpha,1-alpha), na.rm=TRUE) pvalue.carryover <- get.pvalue(att.carryover.boot) } - est.carryover <- t(as.matrix(c(att.carryover, se.carryover, + est.carryover <- t(as.matrix(c(att.carryover, se.carryover, CI.carryover, pvalue.carryover, CI.carryover.bound))) - colnames(est.carryover) <- c("ATT.carryover", "S.E.", + colnames(est.carryover) <- c("ATT.carryover", "S.E.", "CI.lower", "CI.upper", "p.value", "CI.lower(90%)","CI.upper(90%)") } @@ -2045,18 +2311,18 @@ fect.boot <- function(Y, if (!is.null(group)) { se.group.att <- apply(group.att.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI == TRUE){ - CI.group.att <- cbind(c(out$group.att) - se.group.att * qnorm(1-alpha/2), + CI.group.att <- cbind(c(out$group.att) - se.group.att * qnorm(1-alpha/2), c(out$group.att) + se.group.att * qnorm(1-alpha/2)) - pvalue.group.att <- (1-pnorm(abs(out$group.att/se.group.att)))*2 + pvalue.group.att <- (1-pnorm(abs(out$group.att/se.group.att)))*2 } else{ CI.group.att <- t(apply(group.att.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) - pvalue.group.att <- apply(group.att.boot, 1, get.pvalue) + pvalue.group.att <- apply(group.att.boot, 1, get.pvalue) } est.group.att <- cbind(out$group.att, se.group.att, CI.group.att, pvalue.group.att) colnames(est.group.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value") - + est.group.out <- list() for(sub.name in group.output.name){ subgroup.atts <- group.output.origin[[sub.name]]$att.on @@ -2066,29 +2332,29 @@ fect.boot <- function(Y, if(dim(subgroup.atts.boot)[1]>0){ subgroup.se.att <- apply(subgroup.atts.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI == FALSE){ - subgroup.CI.att <- cbind(subgroup.atts - subgroup.se.att * qnorm(1-alpha/2), + subgroup.CI.att <- cbind(subgroup.atts - subgroup.se.att * qnorm(1-alpha/2), subgroup.atts + subgroup.se.att * qnorm(1-alpha/2)) subgroup.pvalue.att <- (1-pnorm(abs(subgroup.atts/subgroup.se.att)))*2 - subgroup.att.bound <- cbind(subgroup.atts - subgroup.se.att * qnorm(1-alpha), + subgroup.att.bound <- cbind(subgroup.atts - subgroup.se.att * qnorm(1-alpha), subgroup.atts + subgroup.se.att * qnorm(1-alpha)) } else{ subgroup.CI.att <- t(apply(subgroup.atts.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) - subgroup.pvalue.att <- apply(subgroup.atts.boot, 1, get.pvalue) - subgroup.att.bound <- t(apply(subgroup.atts.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) + subgroup.pvalue.att <- apply(subgroup.atts.boot, 1, get.pvalue) + subgroup.att.bound <- t(apply(subgroup.atts.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) } - subgroup.est.att <- cbind(subgroup.atts, subgroup.se.att , - subgroup.CI.att, subgroup.pvalue.att, + subgroup.est.att <- cbind(subgroup.atts, subgroup.se.att , + subgroup.CI.att, subgroup.pvalue.att, group.output.origin[[sub.name]]$count.on) colnames(subgroup.est.att) <- c("ATT", "S.E.", "CI.lower", "CI.upper", "p.value", "count") rownames(subgroup.est.att) <- group.output.origin[[sub.name]]$time.on - + # for equivalence test colnames(subgroup.att.bound) <- c("CI.lower", "CI.upper") rownames(subgroup.att.bound) <- group.output.origin[[sub.name]]$time.on } - + subgroup.att.off.bound <- NULL subgroup.est.att.off <- NULL if (hasRevs == 1){ @@ -2099,30 +2365,30 @@ fect.boot <- function(Y, subgroup.se.att.off <- apply(subgroup.atts.off.boot, 1, function(vec) sd(vec, na.rm=TRUE)) if(quantile.CI == FALSE){ - subgroup.CI.att.off <- cbind(subgroup.atts.off - subgroup.se.att.off * qnorm(1-alpha/2), + subgroup.CI.att.off <- cbind(subgroup.atts.off - subgroup.se.att.off * qnorm(1-alpha/2), subgroup.atts.off + subgroup.se.att.off * qnorm(1-alpha/2)) - subgroup.pvalue.att.off <- apply(subgroup.atts.off.boot, 1, get.pvalue) - subgroup.att.off.bound <- cbind(subgroup.atts.off - subgroup.se.att.off * qnorm(1-alpha), + subgroup.pvalue.att.off <- apply(subgroup.atts.off.boot, 1, get.pvalue) + subgroup.att.off.bound <- cbind(subgroup.atts.off - subgroup.se.att.off * qnorm(1-alpha), subgroup.atts.off + subgroup.se.att.off * qnorm(1-alpha)) } else{ subgroup.CI.att.off <- t(apply(subgroup.atts.off.boot, 1, function(vec) quantile(vec,c(alpha/2, 1 - alpha/2), na.rm=TRUE))) - subgroup.pvalue.att.off <- apply(subgroup.atts.off.boot, 1, get.pvalue) + subgroup.pvalue.att.off <- apply(subgroup.atts.off.boot, 1, get.pvalue) subgroup.att.off.bound <- t(apply(subgroup.atts.off.boot, 1, function(vec) quantile(vec,c(alpha, 1 - alpha), na.rm=TRUE))) - + } - subgroup.est.att.off <- cbind(subgroup.atts.off, - subgroup.se.att.off, - subgroup.CI.att.off, - subgroup.pvalue.att.off, + subgroup.est.att.off <- cbind(subgroup.atts.off, + subgroup.se.att.off, + subgroup.CI.att.off, + subgroup.pvalue.att.off, group.output.origin[[sub.name]]$count.off) colnames(subgroup.est.att.off) <- c("ATT.OFF", "S.E.", "CI.lower", "CI.upper", "p.value", "count.off") rownames(subgroup.est.att.off) <- group.output.origin[[sub.name]]$time.off - + colnames(subgroup.att.off.bound) <- c("CI.lower", "CI.upper") - rownames(subgroup.att.off.bound) <- group.output.origin[[sub.name]]$time.off - } + rownames(subgroup.att.off.bound) <- group.output.origin[[sub.name]]$time.off + } } ## placebo test @@ -2132,11 +2398,11 @@ fect.boot <- function(Y, if(length(subgroup.att.placebo)>0){ subgroup.se.placebo <- sd(group.att.placebo.boot[[sub.name]], na.rm=TRUE) if(quantile.CI == FALSE){ - subgroup.CI.placebo <- c(subgroup.att.placebo - subgroup.se.placebo * qnorm(1-alpha/2), + subgroup.CI.placebo <- c(subgroup.att.placebo - subgroup.se.placebo * qnorm(1-alpha/2), subgroup.att.placebo + subgroup.se.placebo * qnorm(1-alpha/2)) - subgroup.CI.placebo.bound <- c(subgroup.att.placebo - subgroup.se.placebo * qnorm(1-alpha), + subgroup.CI.placebo.bound <- c(subgroup.att.placebo - subgroup.se.placebo * qnorm(1-alpha), subgroup.att.placebo + subgroup.se.placebo * qnorm(1-alpha)) - subgroup.pvalue.placebo <- (1-pnorm(abs(subgroup.att.placebo/subgroup.se.placebo)))*2 + subgroup.pvalue.placebo <- (1-pnorm(abs(subgroup.att.placebo/subgroup.se.placebo)))*2 } else{ subgroup.CI.placebo <- quantile(group.att.placebo.boot[[sub.name]],c(alpha/2,1-alpha/2), na.rm=TRUE) @@ -2144,27 +2410,27 @@ fect.boot <- function(Y, subgroup.pvalue.placebo <- get.pvalue(group.att.placebo.boot[[sub.name]]) } - subgroup.est.placebo <- t(as.matrix(c(subgroup.att.placebo, - subgroup.se.placebo, - subgroup.CI.placebo, + subgroup.est.placebo <- t(as.matrix(c(subgroup.att.placebo, + subgroup.se.placebo, + subgroup.CI.placebo, subgroup.pvalue.placebo, subgroup.CI.placebo.bound))) - colnames(subgroup.est.placebo) <- c("ATT.placebo", "S.E.", + colnames(subgroup.est.placebo) <- c("ATT.placebo", "S.E.", "CI.lower", "CI.upper", "p.value", - "CI.lower(90%)","CI.upper(90%)") - } + "CI.lower(90%)","CI.upper(90%)") + } } ## carryover test subgroup.est.carryover <- NULL if (!is.null(carryover.period) & carryoverTest == TRUE) { - subgroup.att.carryover <- group.output.origin[[sub.name]]$att.carryover + subgroup.att.carryover <- group.output.origin[[sub.name]]$att.carryover if(length(subgroup.att.carryover)>0){ subgroup.se.carryover <- sd(group.att.carryover.boot[[sub.name]], na.rm=TRUE) if(quantile.CI == FALSE){ - subgroup.CI.carryover <- c(subgroup.att.carryover - subgroup.se.carryover * qnorm(1-alpha/2), + subgroup.CI.carryover <- c(subgroup.att.carryover - subgroup.se.carryover * qnorm(1-alpha/2), subgroup.att.carryover + subgroup.se.carryover * qnorm(1-alpha/2)) - subgroup.CI.carryover.bound <- c(subgroup.att.carryover - subgroup.se.carryover * qnorm(1-alpha), + subgroup.CI.carryover.bound <- c(subgroup.att.carryover - subgroup.se.carryover * qnorm(1-alpha), subgroup.att.carryover + subgroup.se.carryover * qnorm(1-alpha)) subgroup.pvalue.carryover <- (1-pnorm(abs(subgroup.att.carryover/subgroup.se.carryover)))*2 } @@ -2174,14 +2440,14 @@ fect.boot <- function(Y, subgroup.pvalue.carryover <- get.pvalue(group.att.carryover.boot[[sub.name]]) } - subgroup.est.carryover <- t(as.matrix(c(subgroup.att.carryover, - subgroup.se.carryover, - subgroup.CI.carryover, + subgroup.est.carryover <- t(as.matrix(c(subgroup.att.carryover, + subgroup.se.carryover, + subgroup.CI.carryover, subgroup.pvalue.carryover, subgroup.CI.carryover.bound))) - colnames(subgroup.est.carryover) <- c("ATT.carryover", "S.E.", + colnames(subgroup.est.carryover) <- c("ATT.carryover", "S.E.", "CI.lower", "CI.upper", "p.value", - "CI.lower(90%)","CI.upper(90%)") + "CI.lower(90%)","CI.upper(90%)") } } @@ -2198,17 +2464,37 @@ fect.boot <- function(Y, } ##storage + #NULL result if HTEvar not exist + if (length(HTEid) != 1){ + est.avg.HTE = NULL + avg.HTE = NULL + est.avg.HTE.fit = NULL + # est.eff.HTE.fit = NULL + #est.HTEcoef = NULL + Val.HTE = NULL + N.HTE = NULL + est.att.HTE = NULL + } + result<-list(est.avg = est.avg, att.avg.boot = att.avg.boot, est.avg.unit = est.avg.unit, att.avg.unit.boot = att.avg.unit.boot, est.eff.calendar = est.eff.calendar, - est.eff.calendar.fit = est.eff.calendar.fit, + est.eff.calendar.fit = est.eff.calendar.fit, + est.avg.HTE = est.avg.HTE, + avg.HTE = avg.HTE, + est.avg.HTE.fit = est.avg.HTE.fit, + # est.eff.HTE.fit = est.eff.HTE.fit, +# est.HTEcoef = est.HTEcoef, + Val.HTE = Val.HTE, + N.HTE = N.HTE, est.att = est.att, att.bound = att.bound, att.boot = att.boot, - att.vcov = vcov.att, - att.count.boot = att.count.boot) + att.count.boot = att.count.boot, + eff.boot = eff.boot, + est.att.HTE = est.att.HTE) if (p>0) { result <- c(result,list(beta.boot = beta.boot)) @@ -2218,9 +2504,8 @@ fect.boot <- function(Y, } } if (hasRevs == 1) { - result<-c(result,list(est.att.off = est.att.off, - att.off.boot = att.off.boot, - att.off.vcov = vcov.att.off, + result<-c(result,list(est.att.off = est.att.off, + att.off.boot = att.off.boot, att.off.bound = att.off.bound, att.off.count.boot = att.off.count.boot)) } @@ -2233,7 +2518,6 @@ fect.boot <- function(Y, result <- c(result, list(est.balance.att = est.balance.att)) result <- c(result,list(est.balance.avg = est.balance.avg)) result <- c(result,list(balance.att.bound = balance.att.bound, - balance.att.vcov = vcov.balance.att, balance.att.boot = balance.att.boot, balance.count.boot = balance.count.boot)) if (!is.null(placebo.period) & placeboTest == TRUE) { @@ -2245,18 +2529,18 @@ fect.boot <- function(Y, result <- c(result, list(est.avg.W = est.avg.W)) result <- c(result,list(est.att.W = est.att.W)) result <- c(result, list(att.W.bound = att.W.bound)) - result <- c(result, list(att.W.boot = att.on.W.boot, att.W.vcov = vcov.att.W)) + result <- c(result, list(att.W.boot = att.on.W.boot)) if (!is.null(placebo.period) & placeboTest == TRUE) { result <- c(result,list(est.placebo.W = est.placebo.W)) } if (hasRevs == 1) { - result <- c(result,list(est.att.off.W = est.att.off.W, att.off.W.bound = att.off.W.bound, att.off.W.vcov = vcov.att.off.W)) + result <- c(result,list(est.att.off.W = est.att.off.W, att.off.W.bound = att.off.W.bound)) if (!is.null(carryover.period) & carryoverTest == TRUE) { result <- c(result,list(est.carryover.W = est.carryover.W)) } } - } - + } + if (!is.null(placebo.period) & placeboTest == TRUE) { result <- c(result, list(est.placebo = est.placebo, att.placebo.boot = att.placebo.boot)) @@ -2274,7 +2558,7 @@ fect.boot <- function(Y, return(c(out,result)) - + } ## end of boot @@ -2282,7 +2566,7 @@ fect.boot <- function(Y, jackknifed <- function(x, ## ols estimates y, alpha, - quantile.CI = FALSE) { ## sub-sample ols estimates) + quantile.CI = FALSE) { ## sub-sample ols estimates) p <- length(x) N <- dim(y)[2] ## sample size @@ -2291,15 +2575,13 @@ jackknifed <- function(x, ## ols estimates Y <- X - y * (N - 1) Yvar <- apply(Y, 1, var, na.rm = TRUE) - vn <- N - apply(is.na(y), 1, sum) + vn <- N - apply(is.na(y), 1, sum) Ysd <- sqrt(Yvar/vn) ## jackknife se - - vcov_matrix <- 1 / vn * cov(t(Y), use = "pairwise.complete.obs") if(quantile.CI == FALSE){ CI.l <- Ysd * qnorm(alpha/2) + c(x) - CI.u <- Ysd * qnorm(1 - alpha/2) + c(x) + CI.u <- Ysd * qnorm(1 - alpha/2) + c(x) }else{ CI <- t(apply(y, 1, function(vec) quantile(vec,c(0.05/2, 1 - 0.05/2), na.rm=TRUE))) CI.l <- CI[,1] @@ -2316,8 +2598,8 @@ jackknifed <- function(x, ## ols estimates ## P <- 2 * min(1 - pnorm(c(x)/Ysd), pnorm(c(x)/Ysd)) - out <- list(se = Ysd, CI.l = CI.l, CI.u = CI.u, P = P, vcov = vcov_matrix) + out <- list(se = Ysd, CI.l = CI.l, CI.u = CI.u, P = P) return(out) - -} \ No newline at end of file + +} diff --git a/R/cv.R b/R/cv.R index abd3dc0..9a47229 100644 --- a/R/cv.R +++ b/R/cv.R @@ -3,40 +3,46 @@ ################################################################### fect.cv <- function(Y, # Outcome variable, (T*N) matrix X, # Explanatory variables: (T*N*p) array - D, # Indicator for treated unit (tr==1) + D, # Indicator for treated unit (tr==1) W, I, - II, - T.on, - T.off = NULL, - T.on.carry = NULL, + II, + T.on, + T.off = NULL, + T.on.carry = NULL, T.on.balance = NULL, balance.period = NULL, method = "ife", - criterion = "mspe", + criterion = "mspe", k = 5, # CV time cv.prop = 0.1, - cv.treat = TRUE, + cv.treat = TRUE, cv.nobs = 3, cv.donut = 1, min.T0 = 5, r = 0, # initial number of factors considered if CV==1 r.end, proportion = 0, - nlambda = 10, + nlambda = 10, lambda = NULL, - force, + force, hasRevs = 1, + time.on.seq = NULL, tol, # tolerance level max.iteration = 1000, norm.para = NULL, group.level = NULL, - group = NULL - ) { - + group = NULL, + HTEid = NULL, + moderator.type = NULL, + moderator.nbins = 3, + HTE.enp.seq = NULL, + HTEbootVal = NULL + ) { + ##-------------------------------## ## Parsing data - ##-------------------------------## + ##-------------------------------## placebo.pos <- na.pos <- NULL ## unit id and time @@ -45,7 +51,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if (is.null(X) == FALSE) { p <- dim(X)[3] } else { - p <- 0 + p <- 0 X <- array(0, dim = c(1, 1, 0)) } @@ -60,10 +66,10 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix ## replicate data YY <- Y - YY[which(II == 0)] <- 0 ## reset to 0 + YY[which(II == 0)] <- 0 ## reset to 0 if(use_weight){ WW <- W - WW[which(II == 0)] <- 0 ## reset to 0 + WW[which(II == 0)] <- 0 ## reset to 0 } t.on <- c(T.on) T0.min <- min(apply(II, 2, sum)) @@ -89,14 +95,14 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix ## observed Y0 indicator: oci <- which(c(II) == 1) if(use_weight == 1){ - initialOut <- initialFit(data = data.ini, - force = force, + initialOut <- initialFit(data = data.ini, + force = force, w = c(W), - oci = oci) + oci = oci) }else{ - initialOut <- initialFit(data = data.ini, - force = force, - oci = oci) + initialOut <- initialFit(data = data.ini, + force = force, + oci = oci) } Y0 <- initialOut$Y0 @@ -117,7 +123,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix message("Factor number should not be greater than ", T0.min-1, "\n", sep = "") } r.end <- T0.min-1 - } + } else { if (obs.con) { if (method %in% c("both", "ife", "gsynth")) { @@ -129,29 +135,29 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix ##-------------------------------## ## ----------- Main Algorithm ----------- ## ##-------------------------------## - - validX <- 1 ## no multi-colinearity + + validX <- 1 ## no multi-colinearity CV.out.ife <- CV.out.mc <- NULL - + ##----------------------------------------------------## ## Cross-validation of r and lambda ## ##----------------------------------------------------## - + r.max <- min(TT, r.end) r.cv <- 0 ## initial value - + if(method %in% c("ife", "both", "gsynth") && FALSE){ r.cv <- 0 - est.best <- inter_fe_ub(YY, Y0, - X, II, W.use, beta0, - 0, force = force, + est.best <- inter_fe_ub(YY, Y0, + X, II, W.use, beta0, + 0, force = force, tol, max.iteration) message("Cross validation cannot be performed since available pre-treatment records of treated units are too few. So set r.cv = 0.\n ") } else { - r.old <- r ## save the minimal number of factors - message("Cross-validating ...","\n") + r.old <- r ## save the minimal number of factors + message("Cross-validating ...","\n") if(criterion=='mspe'){ message("Criterion: Mean Squared Prediction Error\n") } @@ -181,21 +187,21 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(method == "gsynth"){ message("Interactive fixed effects model...\n") out <- fect.gsynth(Y = Y, D = D, X = X, W = W, I = I, II = II, - T.on = T.on, T.off = T.off, - T.on.balance = T.on.balance, - balance.period = balance.period, + T.on = T.on, T.off = T.off, + T.on.balance = T.on.balance, + balance.period = balance.period, r = r, r.end = r.end, CV = TRUE, - force = force, hasRevs = hasRevs, + force = force, hasRevs = hasRevs, tol = tol, boot = 0, norm.para = norm.para, group.level = group.level, group = group) - return(out) + return(out) } ## ----- ## ## ------------- initialize ------------ ## ## ----- ## - + cv.pos <- which(t.on<=0) t.on.cv <- t.on[cv.pos] count.on.cv <- as.numeric(table(t.on.cv)) @@ -208,18 +214,18 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix #rmCV <- matrix(NA, rm.count, k) ## removed indicator ociCV <- list() rmCV <- list() - estCV <- NULL ## used for mspe + estCV <- NULL ## used for mspe if(use_weight==1){ W.rmCV <- list() } Y0CV <- array(NA, dim = c(TT, N, k)) ## store initial Y0 if (p > 0) { - beta0CV <- array(NA, dim = c(p, 1, k)) + beta0CV <- array(NA, dim = c(p, 1, k)) } else { beta0CV <- array(0, dim = c(1, 0, k)) ## store initial beta0 } - + ## cv.id.all <- c() flag <- 0 for (i in 1:k) { @@ -227,10 +233,10 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix repeat{ cv.n <- cv.n + 1 #cv.id <- cv.sample(II, as.integer(sum(II) - cv.count)) - get.cv <- cv.sample(II, D, - count = rm.count, - cv.count = cv.nobs, - cv.treat = cv.treat, + get.cv <- cv.sample(II, D, + count = rm.count, + cv.count = cv.nobs, + cv.treat = cv.treat, cv.donut = cv.donut) cv.id <- get.cv$cv.id ## cv.id <- sample(oci, as.integer(sum(II) - cv.count), replace = FALSE) @@ -239,7 +245,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix II.cv.valid[cv.id] <- -1 ## ziyi: if certain rows or columns doesn't satisfy con1 or con2, ## replace the row or column of II.cv using the corresponding rows or columns in II - + con1 <- sum(apply(II.cv, 1, sum) >= 1) == TT con2 <- sum(apply(II.cv, 2, sum) >= min.T0) == N @@ -269,9 +275,9 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix ocicv <- setdiff(oci, cv.id) ociCV[[i]] <- ocicv if(use_weight){ - W.estCV <- list() + W.estCV <- list() } - + if(cv.n<200){ estCV <- c(estCV, list(get.cv$est.id)) } @@ -282,18 +288,18 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } if(use_weight == 0){ - initialOutCv <- initialFit(data = data.ini, - force = force, + initialOutCv <- initialFit(data = data.ini, + force = force, oci = ocicv) }else{ - initialOutCv <- initialFit(data = data.ini, - force = force, + initialOutCv <- initialFit(data = data.ini, + force = force, w = c(W), - oci = ocicv) + oci = ocicv) } Y0CV[,,i] <- initialOutCv$Y0 - + if (p > 0) { beta0cv <- initialOutCv$beta0 if (sum(is.na(beta0cv)) > 0) { @@ -306,7 +312,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(flag == 1){ message("Some units have too few pre-treatment observations. Remove them automatically in Cross-Validation.\n") } - + ## get count matrix if(use_weight == 0){ count.T.cv <- count.T.cv.old <- table(T.on) @@ -321,7 +327,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix count.T.cv[cv.drop.index] <- 0 # set weights to 0 for the periods when the number of treated observations is less than proportion } if(use_weight==1){ - count.T.cv <- count.T.cv.old <- aggregate(c(W), by=list(relative = c(T.on)), FUN=sum) + count.T.cv <- count.T.cv.old <- aggregate(c(W), by=list(relative = c(T.on)), FUN=sum) count.T.cv.old <- count.T.cv <- count.T.cv[which(count.T.cv[,'relative']<=0),] cv.prop.cut <- max(count.T.cv.old[,2])*proportion cv.drop.index <- which(count.T.cv.old[,2]<=cv.prop.cut) @@ -337,30 +343,30 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix ## --------------------------------------------- ## ## ---------------- cross validation for ife model ------------------ ## ## --------------------------------------------- ## - + if (method %in% c("ife", "both")) { - + message("Interactive fixed effects model...\n") - + r.pc <- est.pc.best <- MSPE.best <- WMSPE.best <- MSPE.pc.best <- NULL gmoment.best <- moment.best <- MAD.best <- GMSPE.best <- WGMSPE.best <- NULL - + if (criterion == "PC") { CV.out.ife <- matrix(NA, (r.max - r.old + 1), 6) colnames(CV.out.ife) <- c("r", "sigma2", "IC", "PC", "MSPTATT", "MSE") - } + } else { CV.out.ife <- matrix(NA, (r.max - r.old + 1), 13) - colnames(CV.out.ife) <- c("r", "sigma2", "IC", "PC", + colnames(CV.out.ife) <- c("r", "sigma2", "IC", "PC", "MSPE","WMSPE","GMSPE","WGMSPE", "MAD", "Moment", "GMoment", "MSPTATT", "MSE") } - + CV.out.ife[,"r"] <- c(r.old:r.max) CV.out.ife[,"PC"] <- CV.out.ife[,"GMoment"] <- CV.out.ife[,"Moment"] <- CV.out.ife[,"MAD"] <- CV.out.ife[,"MSPE"] <- CV.out.ife[,"WMSPE"] <- CV.out.ife[,"GMSPE"] <- CV.out.ife[,"WGMSPE"] <- 1e20 - for (i in 1:dim(CV.out.ife)[1]) { ## cross-validation loop starts - ## inter FE based on control, before & after - r <- CV.out.ife[i, "r"] + for (i in 1:dim(CV.out.ife)[1]) { ## cross-validation loop starts + ## inter FE based on control, before & after + r <- CV.out.ife[i, "r"] ## k <- 5 if (criterion %in% c("mspe","wmspe","gmspe","wgmspe","mad","moment")) { SSE <- 0 @@ -380,33 +386,33 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix W.use2 <- W.use W.use2[rmCV[[ii]]] <- 0 }else{W.use2 <- as.matrix(0)} - est.cv.fit <- inter_fe_ub(YY.cv, as.matrix(Y0CV[,,ii]), X, II.cv, - W.use2, as.matrix(beta0CV[,,ii]), + est.cv.fit <- inter_fe_ub(YY.cv, as.matrix(Y0CV[,,ii]), X, II.cv, + W.use2, as.matrix(beta0CV[,,ii]), r, force, tol, max.iteration)$fit index.cv <- as.character(T.on[estCV[[ii]]]) index.cv[which(is.na(index.cv))] <- "Control" weight.cv <- count.T.cv[index.cv] names(weight.cv) <- NULL if(use_weight == 0){ - SSE <- SSE + sum((YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) + SSE <- SSE + sum((YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) WSSE <- WSSE + sum(weight.cv*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) GSSE <- GSSE + sum(log((YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2)) ll <- weight.cv*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2 - ll <- ll[which(ll>0)] + ll <- ll[which(ll>0)] WGSSE <- WGSSE + sum(log(ll)) ll.length <- ll.length + length(ll) - MAD.list <- c(MAD.list,(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) + MAD.list <- c(MAD.list,(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) }else{ W.estCV[[ii]] <- WW[estCV[[ii]]] #print(WW[estCV[[ii]]]) - SSE <- SSE + sum(WW[estCV[[ii]]]*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) + SSE <- SSE + sum(WW[estCV[[ii]]]*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) WSSE <- WSSE + sum(WW[estCV[[ii]]]*weight.cv*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) GSSE <- GSSE + sum(WW[estCV[[ii]]]*log((YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2)) ll <- WW[estCV[[ii]]]*weight.cv*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2 - ll <- ll[which(ll>0)] + ll <- ll[which(ll>0)] WGSSE <- WGSSE + sum(log(ll)) ll.length <- ll.length + length(ll) - MAD.list <- c(MAD.list,WW[estCV[[ii]]]*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) + MAD.list <- c(MAD.list,WW[estCV[[ii]]]*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) } # moment conditions moment.list <- c(moment.list,(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])) @@ -424,7 +430,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix WMSPE <- WSSE/(length(unlist(estCV))) GMSPE <- exp(GSSE/(length(unlist(estCV)))) WGMSPE <- exp(WGSSE/ll.length) - MAD <- median(abs(MAD.list-median(MAD.list))) + MAD <- median(abs(MAD.list-median(MAD.list))) }else{ MSPE <- SSE/(sum(unlist(W.estCV))) WMSPE <- WSSE/(sum(unlist(W.estCV))) @@ -445,21 +451,21 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix names(weight.cv) <- NULL names(weight.cv.g) <- NULL moment <- sum(weight.cv*resid.mean)/sum(weight.cv) - gmoment <- sum(weight.cv.g*resid.g.mean)/sum(weight.cv) - + gmoment <- sum(weight.cv.g*resid.g.mean)/sum(weight.cv) + } - est.cv <- inter_fe_ub(YY, - Y0, - X, + est.cv <- inter_fe_ub(YY, + Y0, + X, II, - W.use, - beta0, - r, - force, + W.use, + beta0, + r, + force, tol, max.iteration) ## overall - sigma2 <- est.cv$sigma2 + sigma2 <- est.cv$sigma2 IC <- est.cv$IC PC <- est.cv$PC @@ -487,7 +493,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.ife[,"MSPE"]) - MSPE) > 0.01*min(CV.out.ife[,"MSPE"])) { ## at least 1% improvement for MPSE MSPE.best <- MSPE - est.best <- est.cv + est.best <- est.cv r.cv <- r } else { if (r == r.cv + 1) message("*") @@ -497,9 +503,9 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.ife[,"WMSPE"]) - WMSPE) > 0.01*min(CV.out.ife[,"WMSPE"])) { ## at least 1% improvement for MPSE WMSPE.best <- WMSPE - est.best <- est.cv + est.best <- est.cv r.cv <- r - } + } else { if (r == r.cv + 1) message("*") } @@ -508,9 +514,9 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.ife[,"GMSPE"]) - GMSPE) > 0.01*min(CV.out.ife[,"GMSPE"])) { ## at least 1% improvement for MPSE GMSPE.best <- GMSPE - est.best <- est.cv + est.best <- est.cv r.cv <- r - } + } else { if (r == r.cv + 1) message("*") } @@ -519,9 +525,9 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.ife[,"WGMSPE"]) - WGMSPE) > 0.01*min(CV.out.ife[,"WGMSPE"])) { ## at least 1% improvement for MPSE WGMSPE.best <- WGMSPE - est.best <- est.cv + est.best <- est.cv r.cv <- r - } + } else { if (r == r.cv + 1) message("*") } @@ -529,9 +535,9 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix else if(criterion == 'mad'){ if ((min(CV.out.ife[,"MAD"]) - MAD) > 0.01*min(CV.out.ife[,"MAD"])) { MAD.best <- MAD - est.best <- est.cv + est.best <- est.cv r.cv <- r - } + } else { if (r == r.cv + 1) message("*") } @@ -539,9 +545,9 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix else if(criterion == 'moment'){ if ((min(CV.out.ife[,"Moment"]) - moment) > 0.01*min(CV.out.ife[,"Moment"])) { moment.best <- moment - est.best <- est.cv + est.best <- est.cv r.cv <- r - } + } else { if (r == r.cv + 1) message("*") } @@ -549,16 +555,16 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix else if(criterion == 'gmoment'){ if ((min(CV.out.ife[,"GMoment"]) - gmoment) > 0.01*min(CV.out.ife[,"GMoment"])) { gmoment.best <- gmoment - est.best <- est.cv + est.best <- est.cv r.cv <- r - } + } else { if (r == r.cv + 1) message("*") } } else if(criterion == "pc"){ if (PC < min(CV.out.ife[,"PC"])) { - est.pc.best <- est.cv + est.pc.best <- est.cv r.pc <- r } } @@ -568,7 +574,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } else { CV.out.ife[i, 2:6] <- c(sigma2, IC, PC, MSPTATT, MSE) } - + if (criterion == "pc") { message("\n r = ",r, "; sigma2 = ", sprintf("%.5f",sigma2), "; IC = ", @@ -593,16 +599,16 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix sprintf("%.5f",PC), "; MSPE = ", sprintf("%.5f",MSPE)) } - } ## end of while: search for r_star over + } ## end of while: search for r_star over #MSPE.best <- min(CV.out[,"MSPE"]) #PC.best <- min(CV.out[,"PC"]) - ## compare + ## compare if (criterion == "both") { if (r.cv > r.pc) { message("\n\n Factor number selected via cross validation may be larger than the true number. Using the PC criterion.\n\n ") - r.cv <- r.pc + r.cv <- r.pc est.best <- est.pc.best MSPE.best <- MSPE.pc.best } @@ -610,7 +616,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix MSPE.best.ife <- MSPE.best } else if (criterion == "pc") { - est.best.ife <- est.pc.best + est.best.ife <- est.pc.best r.cv <- r.pc } else { @@ -623,10 +629,10 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix moment.best.ife <- moment.best gmoment.best.ife <- gmoment.best } - + if (r > (TT-1)) {message(" (r hits maximum)")} message("\n\n r* = ",r.cv, sep="") - message("\n\n") + message("\n\n") } ## ------------------------------------- ## @@ -637,8 +643,8 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix eigen.all <- NULL if (is.null(lambda) || length(lambda) == 1) { ## create the hyper-parameter sequence - ## biggest candidate lambda - ## Y.lambda <- YY + ## biggest candidate lambda + ## Y.lambda <- YY Y.lambda <- YY - Y0 ## Y.lambda[which(II == 0)] <- Y0[which(II == 0)] Y.lambda[which(II == 0)] <- 0 @@ -653,7 +659,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix lambda[i] <- 10^(lambda.max - (i - 1) * lambda.by) } lambda[nlambda] <- 0 - } + } else { Y.lambda <- YY - Y0 Y.lambda[which(II == 0)] <- 0 @@ -672,7 +678,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix break_count <- 0 break_check <- 0 - for (i in 1:length(lambda)) { + for (i in 1:length(lambda)) { ## k <- 5 SSE <- 0 WSSE <- 0 @@ -692,32 +698,32 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix W.use2 <- W.use W.use2[rmCV[[ii]]] <- 0 }else{W.use2 <- as.matrix(0)} - est.cv.fit <- inter_fe_mc(YY.cv, as.matrix(Y0CV[,,ii]), - X, II.cv, W.use2, as.matrix(beta0CV[,,ii]), + est.cv.fit <- inter_fe_mc(YY.cv, as.matrix(Y0CV[,,ii]), + X, II.cv, W.use2, as.matrix(beta0CV[,,ii]), 1, lambda[i], force, tol, max.iteration)$fit index.cv <- as.character(T.on[estCV[[ii]]]) index.cv[which(is.na(index.cv))] <- "Control" weight.cv <- count.T.cv[index.cv] names(weight.cv) <- NULL if(use_weight == 0){ - SSE <- SSE + sum((YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) + SSE <- SSE + sum((YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) WSSE <- WSSE + sum(weight.cv*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) GSSE <- GSSE + sum(log((YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2)) ll <- weight.cv*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2 - ll <- ll[which(ll>0)] + ll <- ll[which(ll>0)] WGSSE <- WGSSE + sum(log(ll)) ll.length <- ll.length + length(ll) - MAD.list <- c(MAD.list,(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) + MAD.list <- c(MAD.list,(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) }else{ W.estCV[[ii]] <- WW[estCV[[ii]]] - SSE <- SSE + sum(WW[estCV[[ii]]]*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) + SSE <- SSE + sum(WW[estCV[[ii]]]*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) WSSE <- WSSE + sum(WW[estCV[[ii]]]*weight.cv*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) GSSE <- GSSE + sum(WW[estCV[[ii]]]*log((YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2)) ll <- WW[estCV[[ii]]]*weight.cv*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2 - ll <- ll[which(ll>0)] + ll <- ll[which(ll>0)] WGSSE <- WGSSE + sum(log(ll)) ll.length <- ll.length + length(ll) - MAD.list <- c(MAD.list,WW[estCV[[ii]]]*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) + MAD.list <- c(MAD.list,WW[estCV[[ii]]]*(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])^2) } # moment conditions moment.list <- c(moment.list,(YY[estCV[[ii]]]-est.cv.fit[estCV[[ii]]])) @@ -728,7 +734,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix WMSPE <- WSSE/(length(unlist(estCV))) GMSPE <- exp(GSSE/(length(unlist(estCV)))) WGMSPE <- exp(WGSSE/ll.length) - MAD <- median(abs(MAD.list-median(MAD.list))) + MAD <- median(abs(MAD.list-median(MAD.list))) }else{ MSPE <- SSE/(sum(unlist(W.estCV))) WMSPE <- WSSE/(sum(unlist(W.estCV))) @@ -736,7 +742,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix WGMSPE <- exp(WGSSE/ll.length) MAD <- median(abs(MAD.list-median(MAD.list))) } - + # moment resid.mean <- tapply(moment.list,index.moment.list, mean) resid.mean <- abs(resid.mean) @@ -752,13 +758,13 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix moment <- sum(weight.cv*resid.mean)/sum(weight.cv) gmoment <- sum(weight.cv.g*resid.g.mean)/sum(weight.cv) - est.cv <- inter_fe_mc(YY, Y0, X, II, W.use, beta0, - 1, lambda[i], + est.cv <- inter_fe_mc(YY, Y0, X, II, W.use, beta0, + 1, lambda[i], force, tol, max.iteration) ## overall eff.v.cv <- c(Y - est.cv$fit)[cv.pos] meff <- as.numeric(tapply(eff.v.cv, t.on.cv, mean)) - MSPTATT <- sum(meff^2*count.on.cv)/sum(count.on.cv) + MSPTATT <- sum(meff^2*count.on.cv)/sum(count.on.cv) MSE <- sum(eff.v.cv^2)/length(eff.v.cv) if(!is.null(norm.para)) { @@ -775,7 +781,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.mc[,"MSPE"]) - MSPE) > 0.01*min(CV.out.mc[,"MSPE"])) { ## at least 1% improvement for MPSE MSPE.best <- MSPE - est.best <- est.cv + est.best <- est.cv lambda.cv <- lambda[i] break_count <- 0 break_check <- 0 @@ -784,8 +790,8 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if (lambda.cv == lambda[i-1]){ message("*") break_check <- 1 - break_count <- 0 - } + break_count <- 0 + } } } } @@ -793,17 +799,17 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.mc[,"WMSPE"]) - WMSPE) > 0.01*min(CV.out.mc[,"WMSPE"])) { ## at least 1% improvement for MPSE WMSPE.best <- WMSPE - est.best <- est.cv + est.best <- est.cv lambda.cv <- lambda[i] break_check <- 0 break_count <- 0 - } + } else { if (i > 1) { if (lambda.cv == lambda[i-1]){ message("*") break_check <- 1 - break_count <- 0 + break_count <- 0 } } } @@ -812,17 +818,17 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.mc[,"GMSPE"]) - GMSPE) > 0.01*min(CV.out.mc[,"GMSPE"])) { ## at least 1% improvement for MPSE GMSPE.best <- GMSPE - est.best <- est.cv + est.best <- est.cv lambda.cv <- lambda[i] break_check <- 0 break_count <- 0 - } + } else { if (i > 1) { if (lambda.cv == lambda[i-1]){ message("*") break_check <- 1 - break_count <- 0 + break_count <- 0 } } } @@ -831,17 +837,17 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.mc[,"WGMSPE"]) - WGMSPE) > 0.01*min(CV.out.mc[,"WGMSPE"])) { ## at least 1% improvement for MPSE WGMSPE.best <- WGMSPE - est.best <- est.cv + est.best <- est.cv lambda.cv <- lambda[i] break_check <- 0 break_count <- 0 - } + } else { if (i > 1) { if (lambda.cv == lambda[i-1]){ message("*") break_check <- 1 - break_count <- 0 + break_count <- 0 } } } @@ -850,17 +856,17 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.mc[,"MAD"]) - MAD) > 0.01*min(CV.out.mc[,"MAD"])) { ## at least 1% improvement for MPSE MAD.best <- MAD - est.best <- est.cv + est.best <- est.cv lambda.cv <- lambda[i] break_check <- 0 break_count <- 0 - } + } else { if (i > 1) { if (lambda.cv == lambda[i-1]){ message("*") break_check <- 1 - break_count <- 0 + break_count <- 0 } } } @@ -869,17 +875,17 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.mc[,"Moment"]) - moment) > 0.01*min(CV.out.mc[,"Moment"])) { ## at least 1% improvement for MPSE moment.best <- moment - est.best <- est.cv + est.best <- est.cv lambda.cv <- lambda[i] break_check <- 0 break_count <- 0 - } + } else { if (i > 1) { if (lambda.cv == lambda[i-1]){ message("*") break_check <- 1 - break_count <- 0 + break_count <- 0 } } } @@ -888,17 +894,17 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if ((min(CV.out.mc[,"GMoment"]) - gmoment) > 0.01*min(CV.out.mc[,"GMoment"])) { ## at least 1% improvement for MPSE gmoment.best <- gmoment - est.best <- est.cv + est.best <- est.cv lambda.cv <- lambda[i] break_check <- 0 break_count <- 0 - } + } else { if (i > 1) { if (lambda.cv == lambda[i-1]){ message("*") break_check <- 1 - break_count <- 0 + break_count <- 0 } } } @@ -912,13 +918,13 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix message("\n lambda.norm = ", sprintf("%.5f",lambda[i]/max(eigen.all)),"; MSPE = ", sprintf("%.5f",MSPE), "; MSPTATT = ", - sprintf("%.5f",MSPTATT), "; MSE = ", + sprintf("%.5f",MSPTATT), "; MSE = ", sprintf("%.5f",MSE), sep="") if(break_count == 3){ break } } - est.best.mc <- est.best + est.best.mc <- est.best MSPE.best.mc <- MSPE.best WMSPE.best.mc <- WMSPE.best GMSPE.best.mc <- GMSPE.best @@ -929,13 +935,13 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix message("\n\n lambda.norm* = ",lambda.cv/max(eigen.all), sep="") message("\n\n") } - } ## End of Cross-Validation + } ## End of Cross-Validation if (method == "ife") { est.best <- est.best.ife validF <- ifelse(r.cv > 0, 1, 0) - } + } else if (method == "mc") { est.best <- est.best.mc validF <- est.best$validF @@ -944,7 +950,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(criterion == 'mspe'){ if (MSPE.best.ife <= MSPE.best.mc) { est.best <- est.best.ife - validF <- ifelse(r.cv > 0, 1, 0) + validF <- ifelse(r.cv > 0, 1, 0) method <- "ife" } else { est.best <- est.best.mc @@ -955,7 +961,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(criterion == 'wmspe'){ if (WMSPE.best.ife <= WMSPE.best.mc) { est.best <- est.best.ife - validF <- ifelse(r.cv > 0, 1, 0) + validF <- ifelse(r.cv > 0, 1, 0) method <- "ife" } else { est.best <- est.best.mc @@ -966,7 +972,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(criterion == 'gmspe'){ if (GMSPE.best.ife <= GMSPE.best.mc) { est.best <- est.best.ife - validF <- ifelse(r.cv > 0, 1, 0) + validF <- ifelse(r.cv > 0, 1, 0) method <- "ife" } else { est.best <- est.best.mc @@ -977,7 +983,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(criterion == 'wgmspe'){ if (WGMSPE.best.ife <= WGMSPE.best.mc) { est.best <- est.best.ife - validF <- ifelse(r.cv > 0, 1, 0) + validF <- ifelse(r.cv > 0, 1, 0) method <- "ife" } else { est.best <- est.best.mc @@ -988,7 +994,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(criterion == 'mad'){ if (MAD.best.ife <= MAD.best.mc) { est.best <- est.best.ife - validF <- ifelse(r.cv > 0, 1, 0) + validF <- ifelse(r.cv > 0, 1, 0) method <- "ife" } else { est.best <- est.best.mc @@ -999,7 +1005,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(criterion == 'moment'){ if (moment.best.ife <= moment.best.mc) { est.best <- est.best.ife - validF <- ifelse(r.cv > 0, 1, 0) + validF <- ifelse(r.cv > 0, 1, 0) method <- "ife" } else { est.best <- est.best.mc @@ -1010,7 +1016,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix if(criterion == 'gmoment'){ if (gmoment.best.ife <= gmoment.best.mc) { est.best <- est.best.ife - validF <- ifelse(r.cv > 0, 1, 0) + validF <- ifelse(r.cv > 0, 1, 0) method <- "ife" } else { est.best <- est.best.mc @@ -1020,37 +1026,37 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } message("\n\n Recommended method through cross-validation: ", method, sep = "") message("\n\n") - } - validX <- est.best$validX + } + validX <- est.best$validX ##------------------------------## ## ----------- Summarize -------------- ## - ##------------------------------## + ##------------------------------## ## 00. run a fect to obtain residuals if (method == "ife") { if (r.cv == 0) { est.fect <- est.best - } + } else { est.fect <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, 0, force = force, tol, max.iteration) } - } + } else { est.fect <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, 0, force = force, tol, max.iteration) } - + ##-------------------------------## ## ATT and Counterfactuals ## ##-------------------------------## - ## we first adjustment for normalization + ## we first adjustment for normalization if (!is.null(norm.para)) { Y <- Y * norm.para[1] if (method == "ife") { - ## variance of the error term + ## variance of the error term sigma2 <- est.best$sigma2 * (norm.para[1]^2) IC <- est.best$IC - log(est.best$sigma2) + log(sigma2) PC <- est.best$PC * (norm.para[1]^2) @@ -1060,22 +1066,22 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } ## output of estimates - est.best$mu <- est.best$mu * norm.para[1] + est.best$mu <- est.best$mu * norm.para[1] if (method == "ife" && r.cv > 0) { est.best$lambda <- est.best$lambda * norm.para[1] est.best$VNT <- est.best$VNT * norm.para[1] } if (force%in%c(1, 3)) { - est.best$alpha <- est.best$alpha * norm.para[1] + est.best$alpha <- est.best$alpha * norm.para[1] } if (force%in%c(2,3)) { - est.best$xi <- est.best$xi * norm.para[1] + est.best$xi <- est.best$xi * norm.para[1] } #if (p>0) { # est.best$beta <- est.best$beta * norm.para[1] #} - est.best$residuals <- est.best$residuals * norm.para[1] - est.best$fit <- est.best$fit * norm.para[1] + est.best$residuals <- est.best$residuals * norm.para[1] + est.best$fit <- est.best$fit * norm.para[1] est.fect$fit <- est.fect$fit * norm.para[1] est.fect$sigma2 <- est.fect$sigma2 * norm.para[1] } @@ -1083,7 +1089,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix ## 0. revelant parameters sigma2 <- IC <- PC <- NULL if (method == "ife") { - sigma2 <- est.best$sigma2 + sigma2 <- est.best$sigma2 IC <- est.best$IC PC <- est.best$PC } @@ -1097,11 +1103,11 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } else { beta <- NA } - + ## 1. estimated att and counterfactuals Y.ct.equiv <- Y.ct <- NULL Y.ct <- est.best$fit - eff <- Y - Y.ct + eff <- Y - Y.ct missing.index <- which(is.na(eff)) if(length(missing.index)>0){ I[missing.index] <- 0 @@ -1109,7 +1115,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } if (0 %in% I) { eff[which(I == 0)] <- NA - } + } complete.index <- which(!is.na(eff)) att.avg <- sum(eff[complete.index] * D[complete.index])/(sum(D[complete.index])) @@ -1149,8 +1155,8 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } est.best$residuals[which(II == 0)] <- NA if (method == "mc") { - est.best$sigma2 <- mean(c(est.best$residuals[which(II == 1)])^2) ## mean squared error of residuals - } + est.best$sigma2 <- mean(c(est.best$residuals[which(II == 1)])^2) ## mean squared error of residuals + } ## 4. dynamic effects t.on <- c(T.on) @@ -1210,16 +1216,16 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix att.on.sum.W <- att.on.W <- count.on.W <- time.on.W <- W.on.sum <- NULL } - ## 4.2 balance effect - balance.att <- NULL + ## 4.2 balance effect + balance.att <- NULL if (!is.null(balance.period)) { t.on.balance <- c(T.on.balance) - rm.pos4 <- which(is.na(t.on.balance)) + rm.pos4 <- which(is.na(t.on.balance)) t.on.balance.use <- t.on.balance if (NA %in% eff.v | NA %in% t.on.balance) { eff.v.use3 <- eff.v[-c(rm.pos1, rm.pos4)] - t.on.balance.use <- t.on.balance[-c(rm.pos1, rm.pos4)] + t.on.balance.use <- t.on.balance[-c(rm.pos1, rm.pos4)] } balance.time <- sort(unique(t.on.balance.use)) @@ -1228,17 +1234,17 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } - - ## 5 carryover effect - carry.att <- NULL + + ## 5 carryover effect + carry.att <- NULL if (!is.null(T.on.carry)) { t.on.carry <- c(T.on.carry) - rm.pos4 <- which(is.na(t.on.carry)) + rm.pos4 <- which(is.na(t.on.carry)) t.on.carry.use <- t.on.carry if (NA %in% eff.v | NA %in% t.on.carry) { eff.v.use3 <- eff.v[-c(rm.pos1, rm.pos4)] - t.on.carry.use <- t.on.carry[-c(rm.pos1, rm.pos4)] + t.on.carry.use <- t.on.carry[-c(rm.pos1, rm.pos4)] } carry.time <- sort(unique(t.on.carry.use)) @@ -1248,7 +1254,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix # carry.att.med <- rep(NA, length(time.on.carry.seq)) # carry.att.med[which(time.on.carry.seq %in% carry.time)] <- carry.att # carry.att <- carry.att.med - + #} } @@ -1256,7 +1262,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix ## 6. switch-off effects eff.off <- eff.equiv <- off.sd <- NULL - if (hasRevs == 1) { + if (hasRevs == 1) { t.off <- c(T.off) rm.pos3 <- which(is.na(t.off)) eff.v.use2 <- eff.v @@ -1295,7 +1301,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } time.off.W <- sort(unique(t.off.use.W)) - att.off.sum.W <- as.numeric(tapply(eff.v.use2.W*W.v.use2, t.off.use.W, sum)) + att.off.sum.W <- as.numeric(tapply(eff.v.use2.W*W.v.use2, t.off.use.W, sum)) W.off.sum <- as.numeric(tapply(W.v.use2, t.off.use.W, sum)) att.off.W <- att.off.sum.W/W.off.sum ## NA already removed count.off.W <- as.numeric(table(t.off.use.W)) @@ -1313,7 +1319,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix T.calendar <- c(1:TT) if(sum(!is.na(eff.calendar))>1){ #loess fit - loess.fit <- suppressWarnings(try(loess(eff.calendar~T.calendar,weights = N.calendar),silent=TRUE)) + loess.fit <- suppressWarnings(try(loess(eff.calendar~T.calendar,weights = N.calendar),silent=TRUE)) if('try-error' %in% class(loess.fit)){ eff.calendar.fit <- eff.calendar calendar.enp <- NULL @@ -1321,7 +1327,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix else{ eff.calendar.fit <- eff.calendar eff.calendar.fit[which(!is.na(eff.calendar))] <- loess.fit$fit - calendar.enp <- loess.fit$enp + calendar.enp <- loess.fit$enp } } else{ @@ -1329,6 +1335,292 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix calendar.enp <- NULL } + ## 10. loess HTE by any variable + D.missing <- D + D.missing[which(D == 0)] <- NA + # if ((length(HTEid) != 1 | length(HTEid) == 0){ + # stop("not 1 variable for HTE") + # } + #generate variables for dynamic effects + att.on.HTE = list() + time.on.HTE = list() + count.on.HTE = list() + + + if(length(HTEid) == 1){ + HTEvalue = X[,,HTEid] + + #check the key option moderator.type + if(!is.null(moderator.type)){ + if(! moderator.type %in% c("discrete","continuous")){ + stop("\"moderator.type\" option misspecified. Must be one of followings:\"discrete\",\"continuous\".") + } + } + else { + HTEuni = unique(as.vector(HTEvalue)) + if (length(HTEuni) > 5){ + moderator.type = "continuous" + } else{ + moderator.type = "discrete" + } + } + + if(moderator.type == "discrete"){ #代表离散型变量 + HTEuni = unique(as.vector(HTEvalue)) + # if(length(HTEbootVal) > 0){ + # HTEuni = HTEbootVal + # } + HTEuni <- sort(HTEuni) + avg.HTE <- rep(NA,length(HTEuni)) + N.HTE = rep(0,length(HTEuni)) + Ntr.HTE = rep(0,length(HTEuni)) + Val.HTE = HTEuni + for(i in c(1:length(HTEuni))){ + INDEX <- D.missing + INDEX[which(HTEvalue != HTEuni[i])] <- NA + avg.HTE[i] = mean(INDEX * eff, na.rm = TRUE) + Ntr.HTE[i] = length(INDEX) - length(which(is.na(INDEX))) + N.HTE[i] = length(which(HTEvalue == HTEuni[i])) + + #dynamic effects result storage + temp.index <- which(HTEvalue == HTEuni[i]) + temp.t.on = c(T.on[temp.index]) + temp.eff.v = c(eff[temp.index]) + temp.n.on = c(n.on.use[temp.index]) + + rm.pos1 <- which(is.na(temp.eff.v)) + rm.pos2 <- which(is.na(temp.t.on)) + + temp.eff.v.use1 <- temp.eff.v + temp.t.on.use <- temp.t.on + temp.n.on.use <- rep(1:N, each = TT) + if (NA %in% eff.v | NA %in% t.on) { + temp.eff.v.use1 <- temp.eff.v[-c(rm.pos1, rm.pos2)] + temp.t.on.use <- temp.t.on[-c(rm.pos1, rm.pos2)] + temp.n.on.use <- temp.n.on[-c(rm.pos1, rm.pos2)] + # if (binary == FALSE && boot == FALSE) { + # eff.equiv.v <- eff.equiv.v[-c(rm.pos1, rm.pos2)] + # } + } + + temp.time.on <- sort(unique(temp.t.on.use)) + temp.att.on <- as.numeric(tapply(temp.eff.v.use1, temp.t.on.use, mean)) ## NA already removed + temp.count.on <- as.numeric(table(temp.t.on.use)) + + if (!is.null(time.on.seq)) { + temp.count.on.med <- temp.att.on.med <- rep(NA, length(time.on.seq)) + temp.att.on.med[which(time.on.seq %in% temp.time.on)] <- temp.att.on + temp.count.on.med[which(time.on.seq %in% temp.time.on)] <- temp.count.on + temp.att.on <- temp.att.on.med + temp.count.on <- temp.count.on.med + temp.time.on <- time.on.seq + } + + att.on.HTE[[i]] = temp.att.on + time.on.HTE[[i]] = temp.time.on + count.on.HTE[[i]] = temp.count.on + + } + + # eff.HTE <- eff.HTE[which(N.HTE > 0)] #先把不存在treat对应值的情况删掉 + # Val.HTE <- Val.HTE[which(N.HTE > 0)] + # N.HTE <- N.HTE[which(N.HTE > 0)] + # N.HTE <- N.HTE[which(!is.na(eff.HTE))] #再删掉eff为na的情况 + # Val.HTE <- Val.HTE[which(!is.na(eff.HTE))] + # eff.HTE <- eff.HTE[which(!is.na(eff.HTE))] + # eff.HTE.fit <- eff.HTE + # HTE.enp <- NULL + } + if(moderator.type == "continuous"){ #代表连续型变量 + nbins = moderator.nbins + avg.HTE <- rep(NA,nbins) + N.HTE = rep(0,nbins) + Ntr.HTE = rep(0,nbins) + Val.HTE = rep(NA,nbins) + quan = 1/nbins + HTEquantile = quantile(HTEvalue,seq(quan,1,quan)) + + for(i in c(1:nbins)){ + INDEX <- D.missing + if (i == 1){ + INDEX[which((HTEvalue >= HTEquantile[i]))] <- NA + temp.index <- which(HTEvalue < HTEquantile[i]) + } + else if (i == nbins){ + INDEX[which((HTEvalue < HTEquantile[i - 1]))] <- NA + temp.index <- which(HTEvalue >= HTEquantile[i - 1]) + } + else { + INDEX[which((HTEvalue < HTEquantile[i - 1]) | HTEvalue >= HTEquantile[i])] <- NA + temp.index <- which((HTEvalue >= HTEquantile[i - 1]) & (HTEvalue < HTEquantile[i])) + } + avg.HTE[i] = mean(INDEX * eff, na.rm = TRUE) + Ntr.HTE[i] = length(INDEX) - length(which(is.na(INDEX))) + N.HTE[i] = length(temp.index) + Val.HTE[i] = Val.HTE[i] = quan * i + + temp.t.on = c(T.on[temp.index]) + temp.eff.v = c(eff[temp.index]) + + rm.pos1 <- which(is.na(temp.eff.v)) + rm.pos2 <- which(is.na(temp.t.on)) + + temp.eff.v.use1 <- temp.eff.v + temp.t.on.use <- temp.t.on + temp.n.on.use <- rep(1:N, each = TT) + if (NA %in% eff.v | NA %in% t.on) { + temp.eff.v.use1 <- temp.eff.v[-c(rm.pos1, rm.pos2)] + temp.t.on.use <- temp.t.on[-c(rm.pos1, rm.pos2)] + temp.n.on.use <- temp.n.on.use[-c(rm.pos1, rm.pos2)] + # if (binary == FALSE && boot == FALSE) { + # eff.equiv.v <- eff.equiv.v[-c(rm.pos1, rm.pos2)] + # } + } + + temp.time.on <- sort(unique(temp.t.on.use)) + temp.att.on <- as.numeric(tapply(temp.eff.v.use1, temp.t.on.use, mean)) ## NA already removed + temp.count.on <- as.numeric(table(temp.t.on.use)) + + if (!is.null(time.on.seq)) { + temp.count.on.med <- temp.att.on.med <- rep(NA, length(time.on.seq)) + temp.att.on.med[which(time.on.seq %in% temp.time.on)] <- temp.att.on + temp.count.on.med[which(time.on.seq %in% temp.time.on)] <- temp.count.on + temp.att.on <- temp.att.on.med + temp.count.on <- temp.count.on.med + temp.time.on <- time.on.seq + } + + att.on.HTE[[i]] = temp.att.on + time.on.HTE[[i]] = temp.time.on + count.on.HTE[[i]] = temp.count.on + } + # eff.HTE <- eff.HTE[which(N.HTE > 0)] #把不存在treat对应值的情况删掉 + # Val.HTE <- Val.HTE[which(N.HTE > 0)] + # N.HTE <- N.HTE[which(N.HTE > 0)] + #loess fit + # if(!is.null(HTE.enp.seq)){ + # if(length(HTE.enp.seq)==1 & is.na(HTE.enp.seq)){ + # HTE.enp.seq <- NULL + # } + # } + # if(is.null(HTE.enp.seq)){ + # loess.fit <- suppressWarnings(try(loess(eff.HTE~Val.HTE,weights = N.HTE),silent=TRUE)) + # } + # else{ + # loess.fit <- suppressWarnings(try(loess(eff.HTE~Val.HTE,weights = N.HTE,enp.target=HTE.enp.seq),silent=TRUE)) + # } + # if('try-error' %in% class(loess.fit)){ + # eff.HTE.fit <- eff.HTE + # HTE.enp <- NULL + # } + # else{ + # eff.HTE.fit <- eff.HTE + # eff.HTE.fit[which(!is.na(eff.HTE))] <- loess.fit$fit + # HTE.enp <- loess.fit$enp + # } + # if(is.null(eff.HTE.fit)){ + # eff.HTE.fit <- eff.HTE + # calendar.enp <- NULL + # } + # } + + + + HTEX <- HTEvalue[which(D == 1)] + HTEY <- eff[which(D == 1)] + + + # if(moderator.type == "discrete"){ + # bootVal = HTEuni + # HTEX <- as.factor(HTEX) + # } + # if(moderator.type == "continuous"){ + # bootVal = c(HTEmin,HTEmax) + # } + #regression for HTE estimate + #data_reg <- data.frame(HTEX,HTEY) + #REGout <- lm(HTEY ~ HTEX, data = data_reg) + #HTEcoef <- as.vector(REGout$coefficients[2]) + #print(HTEcoef) + } + + #loess fit for HTE + + if(!is.null(HTE.enp.seq)){ + if(length(HTE.enp.seq)==1 & is.na(HTE.enp.seq)){ + HTE.enp.seq <- NULL + } + } + if(is.null(HTE.enp.seq)){ + loess.HTE.fit <- suppressWarnings(try(loess(avg.HTE~Val.HTE,weights = N.HTE),silent=TRUE)) + } + else{ + loess.HTE.fit <- suppressWarnings(try(loess(avg.HTE~Val.HTE,weights = N.HTE,enp.target=HTE.enp.seq),silent=TRUE)) + } + + if('try-error' %in% class(loess.HTE.fit)){ + avg.HTE.fit <- avg.HTE + HTE.enp <- NULL + } + else{ + avg.HTE.fit <- avg.HTE + avg.HTE.fit[which(!is.na(avg.HTE))] <- loess.HTE.fit$fit + HTE.enp <- loess.HTE.fit$enp + } + if(is.null(avg.HTE.fit)){ + avg.HTE.fit <- avg.HTE + HTE.enp <- NULL + } + + } + else{ + avg.HTE = NULL + Val.HTE = NULL + N.HTE = NULL + Ntr.HTE = NULL + avg.HTE.fit = NULL + HTE.enp = NULL + bootVal = NULL + #HTEcoef = NULL + att.on.HTE = NULL + time.on.HTE = NULL + count.on.HTE = NULL + } + ##10.a dynamic effect by different groups + # if(moderator.type != 0){ + # stop("not seperate groups") + # } + # if(length(HTEuni) > 100){ + # stop("too many groups") + # } + # att.HTE.on <- list() + # time.HTE.on <- list() + # count.HTE.on <- list + # for(j in c(1:length(HTEuni))){ + # INDEX.temp <- which(HTEvalue == HTEuni[j]) + # t.on.temp <- c(T.on[INDEX.temp]) + # eff.v.temp <-c(eff[INDEX.temp]) + # rm.pos1 <- which(is.na(eff.v.temp)) + # rm.pos2 <- which(is.na(t.on.temp)) + # + # eff.v.use1.temp <- eff.v.temp + # t.on.use.temp <- t.on.temp + # n.on.use.temp <- rep(1:N, each = TT) + # if (NA %in% eff.v.temp | NA %in% t.on.temp) { + # eff.v.use1.temp <- eff.v.temp[-c(rm.pos1, rm.pos2)] + # t.on.use.temp <- t.on.temp[-c(rm.pos1, rm.pos2)] + # n.on.use.temp <- n.on.use.temp[-c(rm.pos1, rm.pos2)] + # } + # + # time.on.temp <- sort(unique(t.on.use.temp)) + # att.on.temp <- as.numeric(tapply(eff.v.use1.temp, t.on.use.temp, mean)) ## NA already removed + # count.on.temp <- as.numeric(table(t.on.use.temp)) + # + # time.HTE.on[[j]] <- time.on.temp + # att.HTE.on[[j]] <- att.on.temp + # count.HTE.on[[j]] <- count.on.temp + # } + ## 7. cohort effects if (!is.null(group)) { cohort <- cbind(c(group), c(D), c(eff.v)) @@ -1353,7 +1645,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix t.on.sub <- c(T.on[which(group==sub.group)]) eff.v.sub <- c(eff[which(group==sub.group)]) ## a vector rm.pos1.sub <- which(is.na(eff.v.sub)) - rm.pos2.sub <- which(is.na(t.on.sub)) + rm.pos2.sub <- which(is.na(t.on.sub)) eff.v.use1.sub <- eff.v.sub t.on.use.sub <- t.on.sub if (NA %in% eff.v.sub | NA %in% t.on.sub) { @@ -1362,21 +1654,21 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } if(length(t.on.use.sub)>0){ time.on.sub <- sort(unique(t.on.use.sub)) - att.on.sub <- as.numeric(tapply(eff.v.use1.sub, - t.on.use.sub, + att.on.sub <- as.numeric(tapply(eff.v.use1.sub, + t.on.use.sub, mean)) ## NA already removed count.on.sub <- as.numeric(table(t.on.use.sub)) }else{ time.on.sub <- att.on.sub <- count.on.sub <- NULL } - + suboutput <- list(att.on=att.on.sub, time.on=time.on.sub, count.on=count.on.sub) ## T.off - if (hasRevs == 1) { + if (hasRevs == 1) { t.off.sub <- c(T.off[which(group==sub.group)]) rm.pos3.sub <- which(is.na(t.off.sub)) eff.v.use2.sub <- eff.v.sub @@ -1402,15 +1694,15 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } } - + ##-------------------------------## - ## Storage - ##-------------------------------## + ## Storage + ##-------------------------------## ##control group residuals out<-list( - ## main results + ## main results sigma2 = est.best$sigma2, sigma2.fect = est.fect$sigma2, T.on = T.on, @@ -1424,7 +1716,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix N = N, Ntr = Ntr, Nco = Nco, - p = p, + p = p, D = D, Y = Y, X = X, @@ -1435,10 +1727,10 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix est = est.best, method = method, mu = est.best$mu, - beta = beta, + beta = beta, validX = validX, validF = validF, - niter = est.best$niter, + niter = est.best$niter, time = time.on, att = att.on, count = count.on, @@ -1448,14 +1740,31 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix calendar.enp = calendar.enp, eff.pre = eff.pre, eff.pre.equiv = eff.pre.equiv, + avg.HTE = avg.HTE, + Val.HTE = Val.HTE, + N.HTE = N.HTE, + Ntr.HTE = Ntr.HTE, + avg.HTE.fit = avg.HTE.fit, + HTE.enp = HTE.enp, + #bootVal = bootVal, + #HTEcoef = HTEcoef, pre.sd = pre.sd, rmse = rmse, rmCV = rmCV, estCV = estCV, - res = est.best$res) + res = est.best$res, + # time.HTE = time.HTE.on, + # att.HTE = att.HTE.on, + # count.HTE = count.HTE.on + att.HTE = att.on.HTE, + time.HTE = time.on.HTE, + count.HTE = count.on.HTE, + moderator.type = moderator.type, + moderator.nbins = moderator.nbins + ) if (hasRevs == 1) { - out <- c(out, list(time.off = time.off, + out <- c(out, list(time.off = time.off, att.off = att.off, count.off = count.off, eff.off = eff.off, @@ -1485,7 +1794,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix } if(!is.null(balance.period)){ - out <- c(out, list(balance.att = balance.att, balance.time = balance.time,balance.count = balance.count,balance.avg.att = att.avg.balance)) + out <- c(out, list(balance.att = balance.att, balance.time = balance.time,balance.count = balance.count,balance.avg.att = att.avg.balance)) } if (force == 1) { @@ -1506,13 +1815,13 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix out <- c(out, list(factor = as.matrix(est.best$factor), lambda = as.matrix(est.best$lambda), lambda.tr = as.matrix(est.best$lambda[tr,]), - lambda.co = as.matrix(est.best$lambda[co,]))) + lambda.co = as.matrix(est.best$lambda[co,]))) } } if (method == "mc") { out <- c(out, list(lambda.cv = lambda.cv, lambda.seq = lambda, - lambda.norm = lambda.cv / max(eigen.all), + lambda.norm = lambda.cv / max(eigen.all), eigen.all = eigen.all)) } @@ -1529,7 +1838,7 @@ fect.cv <- function(Y, # Outcome variable, (T*N) matrix out <- c(out, list(group.att = group.att, group.output = group.output)) } - + return(out) } ## cross-validation function ends diff --git a/R/default.R b/R/default.R index 778a9a3..d6cedb2 100644 --- a/R/default.R +++ b/R/default.R @@ -1,4 +1,4 @@ -## Causal inference using counterfactual estimators +## Causal inference using counterfactual estimators ## (fect: fixed effects counterfactuals) ## Version 0.7.0 ## Author: Licheng Liu (Tsinghua), Ye Wang(NYU), Yiqing Xu(Stanford), Ziyi Liu(Uchicago) @@ -11,7 +11,7 @@ ## DEPENDENT FUNCTIONS ## fect.fe() ## interactive fixed effects model ## fect.mc() ## matrix completion -## fect.boot() ## bootstrap +## fect.boot() ## bootstrap ## fitness test ## fect.test ## wild bootstrap @@ -30,7 +30,7 @@ ## generic function fect <- function(formula = NULL, data, # a data frame (long-form) Y, # outcome - D, # treatment + D, # treatment X = NULL, # time-varying covariates W = NULL, # weight group = NULL, # cohort @@ -48,11 +48,10 @@ fect <- function(formula = NULL, data, # a data frame (long-form) cv.donut = 0, ## cv mspe criterion = "mspe", # for ife model: mspe, pc or both binary = FALSE, # probit model - QR = FALSE, # QR or SVD for binary probit + QR = FALSE, # QR or SVD for binary probit method = "fe", # method: e for fixed effects; ife for interactive fe; mc for matrix completion se = FALSE, # report uncertainties vartype = "bootstrap", # bootstrap or jackknife - cl = NULL, quantile.CI = FALSE, nboots = 200, # number of bootstraps alpha = 0.05, # significance level @@ -78,10 +77,14 @@ fect <- function(formula = NULL, data, # a data frame (long-form) carryoverTest = FALSE, # carry-over test carryover.period = NULL, # carry-over period carryover.rm = NULL, - loo = FALSE, # leave one period out placebo + loo = FALSE, # leave one period out placebo permute = FALSE, ## permutation test m = 2, ## block length - normalize = FALSE # accelerate option + normalize = FALSE, # accelerate option + moderator = NULL, #the variable needs heterogeneity estimation + moderator.type = NULL, #data type of moderator + moderator.nbins = 3, #number of bins + HTE.enp.seq = NULL #parameter used in loess fit estimation ) { UseMethod("fect") } @@ -91,7 +94,7 @@ fect <- function(formula = NULL, data, # a data frame (long-form) fect.formula <- function(formula = NULL, data, # a data frame (long-form) Y, # outcome - D, # treatment + D, # treatment X = NULL, # time-varying covariates W = NULL, # weights group = NULL, # cohort @@ -104,16 +107,15 @@ fect.formula <- function(formula = NULL, CV = NULL, # cross-validation k = 10, # times of CV cv.prop = 0.1, ## proportion of CV counts - cv.treat = FALSE, + cv.treat = FALSE, cv.nobs = 3, cv.donut = 0, ## cv mspe criterion = "mspe", # for ife model: mspe, pc or both binary = FALSE, # probit model - QR = FALSE, # QR or SVD for binary probit + QR = FALSE, # QR or SVD for binary probit method = "fe", # method: fe for fixed effects; ife for interactive fe; mc for matrix completion se = FALSE, # report uncertainties vartype = "bootstrap", # bootstrap or jackknife - cl = NULL, quantile.CI = FALSE, nboots = 200, # number of bootstraps alpha = 0.05, # significance level @@ -127,7 +129,7 @@ fect.formula <- function(formula = NULL, proportion = 0.3, pre.periods = NULL, f.threshold = 0.5, # equiv - tost.threshold = NULL, + tost.threshold = NULL, knots = NULL, degree = 2, # wald = FALSE, sfe = NULL, @@ -142,7 +144,11 @@ fect.formula <- function(formula = NULL, loo = FALSE, # leave one period out placebo permute = FALSE, ## permutation test m = 2, ## block length - normalize = FALSE + normalize = FALSE, + moderator = NULL, #the variable needs heterogeneity estimation + moderator.type = NULL, #the data type of moderator, "discrete" or "continuous" + moderator.nbins = 3, #number of bins if the moderator is continuous + HTE.enp.seq = NULL #parameter used in loess fit estimation ) { ## parsing varnames <- all.vars(formula) @@ -154,6 +160,7 @@ fect.formula <- function(formula = NULL, Xname <- NULL } + namesData <- colnames(data) for (i in 1:length(varnames)) { if(!varnames[i] %in% namesData) { @@ -170,66 +177,70 @@ fect.formula <- function(formula = NULL, if (sum(unique_y == c(0,1)) != 2) { stop("Outcome should only contain 0 and 1.") } - } + } } ## run the model - out <- fect.default(formula = NULL, - data = data, + out <- fect.default(formula = NULL, + data = data, Y = Yname, - D = Dname, - X = Xname, + D = Dname, + X = Xname, W = W, group = group, - na.rm = na.rm, + na.rm = na.rm, balance.period = balance.period, fill.missing = fill.missing, - index = index, - force = force, - r = r, - lambda = lambda, - nlambda = nlambda, - CV =CV, - k = k, - cv.prop = cv.prop, - cv.treat = cv.treat, - cv.nobs = cv.nobs, + index = index, + force = force, + r = r, + lambda = lambda, + nlambda = nlambda, + CV =CV, + k = k, + cv.prop = cv.prop, + cv.treat = cv.treat, + cv.nobs = cv.nobs, cv.donut = cv.donut, - criterion = criterion, - binary = binary, - QR = QR, - method = method, - se = se, + criterion = criterion, + binary = binary, + QR = QR, + method = method, + se = se, vartype = vartype, - cl = cl, quantile.CI = quantile.CI, - nboots = nboots, - alpha = alpha, - parallel = parallel, - cores = cores, - tol = tol, + nboots = nboots, + alpha = alpha, + parallel = parallel, + cores = cores, + tol = tol, max.iteration = max.iteration, - seed = seed, + seed = seed, min.T0 = min.T0, - max.missing = max.missing, - proportion = proportion, - pre.periods = pre.periods, - f.threshold = f.threshold, + max.missing = max.missing, + proportion = proportion, + pre.periods = pre.periods, + f.threshold = f.threshold, tost.threshold = tost.threshold, - knots = knots, - degree = degree, + knots = knots, + degree = degree, sfe = sfe, cfe = cfe, - placebo.period = placebo.period, - placeboTest = placeboTest, - carryoverTest = carryoverTest, + placebo.period = placebo.period, + placeboTest = placeboTest, + carryoverTest = carryoverTest, carryover.period = carryover.period, carryover.rm = carryover.rm, loo = loo, - permute = permute, - m = m, - normalize = normalize) - + permute = permute, + m = m, + normalize = normalize, + moderator = moderator, + moderator.type = moderator.type, + moderator.nbins = moderator.nbins, + HTE.enp.seq = HTE.enp.seq + ) + out$call <- match.call() out$formula <- formula return(out) @@ -241,7 +252,7 @@ fect.formula <- function(formula = NULL, fect.default <- function(formula = NULL, data, # a data frame (long-form) Y, # outcome - D, # treatment + D, # treatment X = NULL, # time-varying covariates W = NULL, # weights group = NULL, # cohort @@ -250,20 +261,19 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) force = "two-way", # fixed effects demeaning r = 0, # nubmer of factors lambda = NULL, ## mc method: regularization parameter - nlambda = 0, + nlambda = 0, CV = NULL, # cross-validation k = 10, # times of CV cv.prop = 0.1, - cv.treat = TRUE, + cv.treat = TRUE, cv.nobs = 3, cv.donut = 1, ## cv mspe - criterion = "mspe", + criterion = "mspe", binary = FALSE, # probit model - QR = FALSE, # QR or SVD for binary probit + QR = FALSE, # QR or SVD for binary probit method = "fe", # method: ife for interactive fe; mc for matrix completion se = FALSE, # report uncertainties vartype = "bootstrap", # bootstrap or jackknife - cl = NULL, quantile.CI = FALSE, nboots = 200, # number of bootstraps alpha = 0.05, # significance level @@ -277,7 +287,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) proportion = 0.3, pre.periods = NULL, f.threshold = 0.5, # equiv - tost.threshold = NULL, + tost.threshold = NULL, knots = NULL, degree = 2, # wald = FALSE, sfe = NULL, @@ -288,20 +298,24 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) placebo.period = NULL, # placebo test period carryoverTest = FALSE, # carry-over test carryover.period = NULL, # carry-over period - carryover.rm = NULL, + carryover.rm = NULL, loo = FALSE, # leave one period out placebo permute = FALSE, ## permutation test m = 2, ## block length - normalize = FALSE - ) { - + normalize = FALSE, + moderator = NULL, #the variable needs heterogeneity estimation + moderator.type = NULL, #data type of moderator + moderator.nbins = NULL, #number of bins + HTE.enp.seq = NULL #parameter used in loess fit estimation + ) { + ##-------------------------------## ## Checking Parameters - ##-------------------------------## - placeboEquiv <- loo + ##-------------------------------## + placeboEquiv <- loo permu.dimension <- 'time' - - ## read data + + ## read data if (is.data.frame(data) == FALSE || length(class(data)) > 1) { data <- as.data.frame(data) ## warning("Not a data frame.") @@ -334,7 +348,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) data <- data[which(data[,W]>0),] } } - + ## check duplicated observations unique_label <- unique(paste(data[,index[1]],"_",data[,index[2]],sep="")) if (length(unique_label)!= dim(data)[1]) { @@ -348,13 +362,13 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) force <- 1 } else if (force == "time") { # force = 2 "time": time fixed-effect force <- 2 - } else if (force == "two-way") { # force = 3 "two-way": two-way fixed-effect + } else if (force == "two-way") { # force = 3 "two-way": two-way fixed-effect force <- 3 } - + if (!force %in% c(0, 1, 2, 3)) { stop("\"force\" option misspecified; choose from c(\"none\", \"unit\", \"time\", \"two-way\").") - } + } ## binary if (binary == 1) { @@ -390,7 +404,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) r <- 0 CV <- FALSE method <- "ife" - } + } else if (method %in% c("polynomial","cfe")) { CV <- FALSE } @@ -415,14 +429,14 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) else if(length(lambda)>1 | is.null(lambda)){ CV <- TRUE } - } + } } else{ if (method == "fe") { r <- 0 CV <- FALSE method <- "ife" - } + } else if (method %in% c("polynomial","cfe")) { CV <- FALSE } @@ -454,7 +468,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (method %in% c("mc", "both")) { if (!is.null(lambda)) { if (sum(lambda < 0) > 0) { - stop("\"lambda\" option misspecified. It must be non-negative.") + stop("\"lambda\" option misspecified. It must be non-negative.") } } if (CV == FALSE & is.null(lambda)) { @@ -462,9 +476,9 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) method <- "ife" r <- 0 } - } + } - ## leave one period out placebo + ## leave one period out placebo if (placeboEquiv == TRUE) { if(se!=TRUE){ message("For leave one period out placebo test, automatically set \"se\" to TRUE.") @@ -485,9 +499,9 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } ## CV - + if (CV == TRUE) { - + if (placeboTest == TRUE) { stop("Placebo test cannot be performed while doing cross-validation.") } @@ -500,13 +514,13 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (length(r) == 2 & r[1] > r[2]) { stop("\"r\" option misspecified. The first element should be smaller than the second element in r().\n") } - } + } if (method %in% c("mc", "both")) { if (nlambda <= 0) { stop("\"nlambda\" option misspecified.\n") } } - } + } else { if (! method %in% c("gsynth","ife", "mc", "polynomial","cfe")) { stop("\"method\" option misspecified; please choose from c(\"gsynth\",\"ife\", \"mc\", \"polynomial\").") @@ -539,30 +553,30 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (length(r) == 1) { #if (r>=5) { # r.end <- r - #} + #} #else { # r.end <- 5 #} r.end <- r - } + } else { r.end <- max(r) r <- min(r) } - + ## uncertainty estimates if (is.logical(se) == FALSE & !se%in%c(0, 1)) { stop("\"se\" is not a logical flag.") - } + } if (is.logical(quantile.CI) == FALSE & !quantile.CI%in%c(0, 1)) { stop("\"quantile.CI\" is not a logical flag.") - } + } ## normalize if (is.logical(normalize) == FALSE & !normalize%in%c(0, 1)) { stop("\"normalize\" is not a logical flag.") - } + } ## nboots if (se == TRUE & nboots <= 0) { @@ -576,7 +590,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) stop("\"cores\" option misspecified. Try, for example, cores = 2.") } } - } + } ## tol if (tol <= 0) { @@ -612,24 +626,18 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) stop("\"group\" should not be used with \"balance.period\".\n") } if(!is.null(carryover.rm)){ - stop("\"balance.period\" should not be used with \"carryover.rm\".\n") + stop("\"balance.period\" should not be used with \"carryover.rm\".\n") } balance.periods <- c(balance.period[1]:balance.period[2]) # treat the units with history balance.periods as a certain group } - # cohort + # cohort if (!is.null(group)) { if (! group %in% names(data)) { stop("\"group\" misspecified.\n") - } - } - - if (!is.null(cl)) { - if (! cl %in% names(data)) { - stop("\"cl\" misspecified.\n") } - } + } if(method == 'cfe'){ if(is.null(sfe) & is.null(cfe)){ @@ -648,8 +656,8 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } if(sub.sfe %in% index){ stop("\"sfe\" only contains additional fixed effects.\n") - } - } + } + } } if(!is.null(cfe)){ @@ -666,28 +674,28 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if(sub.cfe[1] == index[1] & sub.cfe[2] %in% X){ stop(paste0("Should remove ",sub.cfe[2]," from X.\n")) } - } + } } } if(method != 'cfe'){ if (!is.null(group)) { - data <- data[,unique(c(index, Y, D, X, W, group,cl))] - } + data <- data[,c(index, Y, D, X, W, group)] + } else { - data <- data[,unique(c(index, Y, D, X, W, cl))] ## some variables may not be used - } + data <- data[,c(index, Y, D, X, W)] ## some variables may not be used + } } else{ - all.var <- unique(c(index,sfe,unlist(cfe),Y,D,X,W,group,cl)) + all.var <- unique(c(index,sfe,unlist(cfe),Y,D,X,W,group)) data <- data[,all.var] } - + if (na.rm == TRUE) { data <- na.omit(data) - } + } else{ if(sum(is.na(data[,D]))>=1 | sum(is.na(data[,index[1]]))>=1 | sum(is.na(data[,index[2]]))>=1){ stop("\"D\" or \"index\" should not have missing values when setting \"na.rm\" to FALSE.") @@ -698,7 +706,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if(sum(is.na(data[,sub.sfe]))>=1){ stop("Variables in \"sfe\" should not have missing values when setting \"na.rm\" to FALSE.") } - } + } } } } @@ -734,21 +742,23 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) ##-------------------------------## ## Parsing raw data - ##-------------------------------## + ##-------------------------------## ## store data and variable names data.old <- data Yname <- Y Dname <- D Xname <- X - clname <- cl + clname <- cl <- NULL Wname <- W - if (!is.null(clname)) { - if (!clname %in% index) { - data[, clname] <- as.numeric(as.factor(data[, clname])) - } - } + #if (!is.null(clname)) { + # if (!clname %in% index) { + # data[, clname] <- as.numeric(as.factor(data[, clname])) + # } + #} + ##calculate HTEid + HTEid = which(Xname == moderator) ## normalize norm.para <- NULL @@ -762,7 +772,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (! class(data[, Dname]) %in% c("numeric", "integer")) { ## data[, Dname] <- as.numeric(as.character(data[, Dname])) stop("Treatment indicator should be a numeric value.") - } + } ## check missingness #if (sum(is.na(data[, Yname])) > 0 & na.rm == TRUE) { @@ -777,12 +787,12 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (class(data[, index[1]])[1] == "factor") { data[, index[1]] <- as.character(data[, index[1]]) - } + } if (class(data[, index[2]])[1] == "factor") { data[, index[2]] <- as.character(data[, index[2]]) - } - + } + id <- index[1] time <- index[2] TT.old <- TT <- length(unique(data[,time])) @@ -797,7 +807,45 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } } + # recode treatment status for osbervations exposed to carryover effects + hasCarryover <- 0 + if (!is.null(carryover.rm)) { + if (length(carryover.rm) == 1 & class(carryover.rm)[1] == "numeric") { + if (carryover.rm > 0) { + newT <- as.numeric(as.factor(data[, time])) + data <- data[order(data[, id], data[, time]),] + tempID <- unique(data[, id]) + for (i in tempID) { + subpos <- which(data[, id] == i) + subtime <- newT[subpos] + subd <- data[subpos, Dname] + if (sum(subd) >= 1) { + tr.time <- subtime[which(subd == 1)] + cr.time <- c() # carryover period + for (k in 1:carryover.rm) { + cr.time <- c(cr.time, tr.time + k) + } + # note: if a period has both treatment effect and carryover effect, + # regard carryover effect as 0 + cr.time <- unique(cr.time) + cr.time <- setdiff(cr.time, tr.time) + + cr.pos <- subpos[which(subtime %in% cr.time)] + + if (length(cr.pos) > 0) { + data[cr.pos, Dname] <- 2 + } + + } + } + + } + } + } + if (2 %in% data[, Dname]) { + hasCarryover <- 1 + } @@ -835,7 +883,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } else{ rm.na.time <- NULL - } + } # here the size of data.full should be smaller than TT*N, larger than length(data) } @@ -850,14 +898,14 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if(!is.null(sfe)){ for(sub.sfe in sfe){ data[,sub.sfe] <- as.numeric(as.factor(data[,sub.sfe])) - } + } } if(!is.null(cfe)){ for(sub.cfe in cfe){ data[,sub.cfe[1]] <- as.numeric(as.factor(data[,sub.cfe[1]])) - } - } + } + } } ## gen group matrix @@ -870,7 +918,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } ##message("\nOK1\n") - + @@ -883,63 +931,57 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if(force %in% c(1,3)){ if (sum(tapply(data[, Xname[i]], data[, id], var), na.rm = TRUE) == 0) { stop(paste("Variable \"",Xname[i], "\" is unit-invariant. Try to remove it.", sep = "")) - } + } } if(force %in% c(2,3)){ if (sum(tapply(data[, Xname[i]], data[, time], var), na.rm = TRUE) == 0) { stop(paste("Variable \"",Xname[i], "\" is time-invariant. Try to remove it.", sep = "")) - } + } } } } - ## check index + ## check index if (sum(is.na(data[, id])) > 0) { stop(paste("Missing values in variable \"", id,"\".", sep = "")) } if (sum(is.na(data[, time])) > 0) { stop(paste("Missing values in variable \"", time,"\".", sep = "")) - } + } ## check balanced panel and fill unbalanced panel if (dim(data)[1] < TT*N) { - + data[,time] <- as.numeric(as.factor(data[,time])) - data[,id] <- as.numeric(as.factor(data[,id])) ob.indicator <- data[,time] id.indicator <- table(data[, id]) sub.start <- 1 - for (i in 1:(N - 1)) { - sub.start <- sub.start + id.indicator[i] - sub.end <- sub.start + id.indicator[i+1] - 1 + for (i in 1:(N - 1)) { + sub.start <- sub.start + id.indicator[i] + sub.end <- sub.start + id.indicator[i+1] - 1 ob.indicator[sub.start:sub.end] <- ob.indicator[sub.start:sub.end] + i * TT } - variable <- c(Yname, Dname, Xname, id, time) - + variable <- c(Yname, Dname, Xname) + if(!is.null(group)) { - variable <- c(variable, group) + variable <- c(Yname, Dname, Xname, group) } if(!is.null(W)){ variable <- c(variable, Wname) - } + } if(method == 'cfe'){ variable <- unique(c(sfe,unlist(cfe),variable)) } - if(!is.null(cl)){ - variable <- unique(c(variable,cl)) - } - data_I <- matrix(0, N * TT, 1) data_I[ob.indicator, 1] <- 1 data_ub <- as.matrix(data[, variable]) data <- data_ub_adj(data_I, data_ub) colnames(data) <- variable - ## data is a TT*N matrix filled with observed pairs (Y/X, D). ## if these exists observations whose Y/X is missing but D is observed. @@ -948,9 +990,9 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) ob.indicator.full <- data.full[,time] id.indicator.full <- table(data.full[, id]) sub.start <- 1 - for (i in 1:(N - 1)) { - sub.start <- sub.start + id.indicator.full[i] - sub.end <- sub.start + id.indicator.full[i+1] - 1 + for (i in 1:(N - 1)) { + sub.start <- sub.start + id.indicator.full[i] + sub.end <- sub.start + id.indicator.full[i+1] - 1 ob.indicator.full[sub.start:sub.end] <- ob.indicator.full[sub.start:sub.end] + i * TT } data_I.full <- matrix(0, N * TT, 1) @@ -963,61 +1005,20 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } } - # recode treatment status for osbervations exposed to carryover effects - hasCarryover <- 0 - - if (!is.null(carryover.rm)) { - if (length(carryover.rm) == 1 & class(carryover.rm)[1] == "numeric") { - if (carryover.rm > 0) { - #print(colnames(data)) - newT <- c(1:TT) - data <- data[order(data[, id], data[, time]),] - tempID <- unique(data[, id]) - for (i in tempID) { - subpos <- which(data[, id] == i) - subtime <- newT[subpos] - subd <- data[subpos, Dname] - if (sum(subd) >= 1) { - tr.time <- subtime[which(subd == 1)] - cr.time <- c() # carryover period - for (k in 1:carryover.rm) { - cr.time <- c(cr.time, tr.time + k) - } - # note: if a period has both treatment effect and carryover effect, - # regard carryover effect as 0 - cr.time <- unique(cr.time) - cr.time <- setdiff(cr.time, tr.time) - - cr.pos <- subpos[which(subtime %in% cr.time)] - - if (length(cr.pos) > 0) { - data[cr.pos, Dname] <- 2 - } - - } - } - - } - } - } - if (2 %in% data[, Dname]) { - hasCarryover <- 1 - } - - ## indicator matrix: index matrix that indicates if data is observed + ## indicator matrix: index matrix that indicates if data is observed I.D <- I <- matrix(1, TT, N) Y.ind <- matrix(data[, Yname], TT, N) D.ind <- matrix(data[, Dname],TT,N) I[is.nan(Y.ind)] <- 0 I.D[is.nan(D.ind)] <- 0 - ## I has more zeros than I.D + ## I has more zeros than I.D ## I.D is used in the function get_term if (0%in%I) { data[is.nan(data)] <- 0 } - ## group indicator + ## group indicator G.old <- G <- NULL if (!is.null(group)) { G <- matrix(data[, group], TT, N) @@ -1036,18 +1037,11 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) G.old <- G } + if(!is.null(W)){ W <- matrix(data[, Wname], TT, N) } - if(!is.null(cl)){ - cl <- matrix(data[, clname], TT, N) - # for each column, replace 0 with the mean of non-zero values - cl <- apply(cl, 2, function(column) { - column[column == 0] <- mean(column[column != 0]) - return(column)}) - } - ## each unit should have the same group index ## message("\nOK2\n") @@ -1062,7 +1056,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (p > 0) { for (i in 1:p) { X[,,i] <- matrix(data[, Xname[i]], TT, N) - } + } } index.matrix <- list() @@ -1072,7 +1066,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) data[,sub.sfe] <- as.numeric(as.factor(data[,sub.sfe])) sub.sfe.matrix <- matrix(data[,sub.sfe], TT, N) index.matrix[[sub.sfe]] <- sub.sfe.matrix - } + } } if(!is.null(cfe)){ @@ -1081,8 +1075,8 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) index.matrix[[sub.cfe[1]]] <- sub.cfe.matrix sub.cfe.matrix <- matrix(data[,sub.cfe[2]], TT, N) index.matrix[[sub.cfe[2]]] <- sub.cfe.matrix - } - } + } + } } @@ -1097,18 +1091,18 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (sum(T0[which(apply(D, 2, sum) > 0)] >= min.T0) == 0) { stop ("All treated units have been removed. Please specify a smaller min.T0.\n") - } - ## T0.min : minimum T0 + } + ## T0.min : minimum T0 ## min.T0: manually set - ## rm.tr.id: relative location of treated units (within all treated units) - ## that will be removed + ## rm.tr.id: relative location of treated units (within all treated units) + ## that will be removed if (T0.min < min.T0) { message(paste0("For identification purposes, units whose number of untreated periods <",min.T0," are dropped automatically.\n")) } rm.id <- sort(unique(c(which((TT - apply(I, 2, sum)) > max.missing), which(T0 < min.T0)))) ## rm.id <- which(T0 < min.T0) ## removed id - ## rem.id <- which(T0 >= min.T0) ## remaining id + ## rem.id <- which(T0 >= min.T0) ## remaining id rem.id <- setdiff(1:N, rm.id) if (length(rm.id) == N) { @@ -1123,7 +1117,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) subX <- X.old[, , i] X[, , i] <- as.matrix(subX[, -rm.id]) } - } + } else { X <- array(0,dim = c(TT, (N - length(rm.id)), 0)) } @@ -1137,9 +1131,6 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (!is.null(group)) { G <- as.matrix(G[,-rm.id]) } - if (!is.null(cl)) { - cl <- as.matrix(cl[,-rm.id]) - } if (!is.null(W)) { W <- as.matrix(W[,-rm.id]) } @@ -1150,10 +1141,10 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } } - ## message("\nOK1\n") + ## message("\nOK1\n") ## 2. check if some periods when all units are missing or treated - I.use <- apply(II, 1, sum) + I.use <- apply(II, 1, sum) if (0%in%I.use) { for (i in 1:TT) { if (I.use[i] == 0) { @@ -1165,10 +1156,10 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } TT <- TT - sum(I.use == 0) time.uni <- time.uni[-which(I.use == 0)] - + I <- I[-which(I.use == 0),] ## remove that period I.D <- I.D[-which(I.use == 0),] - II <- II[-which(I.use == 0),] ## remove that period + II <- II[-which(I.use == 0),] ## remove that period D <- D[-which(I.use == 0),] ## remove that period Y <- Y[-which(I.use == 0),] ## remove that period @@ -1180,10 +1171,6 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) W <- W[-which(I.use == 0),] } - if (!is.null(cl)) { - cl <- cl[-which(I.use == 0),] - } - if(method == "cfe"){ for(ind.name in names(index.matrix)){ index.matrix[[ind.name]] <- as.matrix(index.matrix[[ind.name]][-which(I.use == 0),]) @@ -1202,7 +1189,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } } - ## message("\nOK2\n") + ## message("\nOK2\n") ## 3. relative period T.on <- matrix(NA, TT, (N - length(rm.id))) @@ -1212,27 +1199,27 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) for (i in 1:(N - length(rm.id))) { T.on[, i] <- get_term(D[, i], I.D[, i], type = "on") } - } + } else { - # separate T.on and T.on.carry - D1 <- D2 <- D - D1[which(D1 == 2)] <- 0 + # separate T.on and T.on.carry + D1 <- D2 <- D + D1[which(D1 == 2)] <- 0 D2[which(D2 == 1)] <- 0 - D2[which(D2 == 2)] <- 1 - + D2[which(D2 == 2)] <- 1 T.on.carry <- matrix(NA, TT, (N - length(rm.id))) - + for (i in 1:(N - length(rm.id))) { T.on[, i] <- get_term(D1[, i], I.D[, i], type = "on") T.on.carry[, i] <- get_term(D2[, i], I.D[, i], type = "on") } - T.on[which(D == 2)] <- NA ## remove carryover effect - T.on.carry[which(T.on.carry <= 0)] <- NA ## only keep carryover effect + T.on[which(D == 2)] <- NA ## remove carryover effect + T.on.carry[which(T.on.carry <= 0)] <- NA ## only keep carryover effect + } rm(D1, D2) calendar.time <- as.matrix(replicate((N - length(rm.id)), c(time.uni))) - ##3.1 balance samples + ##3.1 balance samples ## for balance group, add group indicator T.on.balance <- matrix(NA, TT, (N - length(rm.id))) if(!is.null(balance.period)){ @@ -1244,13 +1231,13 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if(fill.missing == TRUE){ T.on.balance <- apply(T.on,2,function(x) v_replace(balance.periods,x)) } - if(sum(!is.na(T.on.balance))==0){ + if(sum(!is.na(T.on.balance))==0){ stop("No Balanced Sample Found.\n") } } - + ## 4. check reversals - D1 <- D + D1 <- D if (hasCarryover == 1) { D1[which(D == 2)] <- 1 } @@ -1269,7 +1256,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) ## 5. switch-off periods T.off <- NULL if (hasRevs == 1) { - T.off <- matrix(NA, TT, (N - length(rm.id))) + T.off <- matrix(NA, TT, (N - length(rm.id))) for (i in 1:(N - length(rm.id))) { T.off[, i] <- get_term(D1[,i], I.D[,i], type = "off") } @@ -1292,10 +1279,10 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (sum(T0.2[which(apply(D, 2, sum) > 0)] >= min.T0) == 0) { stop ("All treated units have been removed in placebo test.\n") - } + } rm.id.2.pos <- sort(which(T0.2 < min.T0)) - rm.id.2 <- rem.id[rm.id.2.pos] + rm.id.2 <- rem.id[rm.id.2.pos] rem.id.2 <- setdiff(rem.id, rm.id.2) rem.id <- rem.id.2 @@ -1325,7 +1312,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) T.on.carry <- as.matrix(T.on.carry[, -rm.id.2.pos]) } if(hasRevs){ - T.off <- as.matrix(T.off[,-rm.id.2.pos]) + T.off <- as.matrix(T.off[,-rm.id.2.pos]) } if (!is.null(group)) { G <- as.matrix(G[,-rm.id.2.pos]) @@ -1333,19 +1320,15 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (!is.null(W)) { W <- as.matrix(W[,-rm.id.2.pos]) } - if (!is.null(cl)) { - cl <- as.matrix(cl[,-rm.id.2.pos]) - } - if(method == "cfe"){ for(ind.name in names(index.matrix)){ index.matrix[[ind.name]] <- as.matrix(index.matrix[[ind.name]][,-rm.id.2.pos]) } } - } + } } - ## 7. Carryover Test + ## 7. Carryover Test ## testcarryover.period = c(1,3) if(hasRevs == 1 & carryoverTest==TRUE & is.null(carryover.period)==FALSE){ II.origin <- II @@ -1361,10 +1344,10 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (sum(T0.3[which(apply(D, 2, sum) > 0)] >= min.T0) == 0) { stop ("All treated units have been removed in carryover test.\n") - } + } rm.id.3.pos <- sort(which(T0.3 < min.T0)) - rm.id.3 <- rem.id[rm.id.3.pos] + rm.id.3 <- rem.id[rm.id.3.pos] rem.id.3 <- setdiff(rem.id, rm.id.3) rem.id <- rem.id.3 @@ -1394,7 +1377,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) T.on.carry <- as.matrix(T.on.carry[, -rm.id.3.pos]) } if(hasRevs){ - T.off <- as.matrix(T.off[,-rm.id.3.pos]) + T.off <- as.matrix(T.off[,-rm.id.3.pos]) } if (!is.null(group)) { G <- as.matrix(G[,-rm.id.3.pos]) @@ -1402,9 +1385,6 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (!is.null(W)) { W <- as.matrix(W[,-rm.id.3.pos]) } - if (!is.null(cl)) { - cl <- as.matrix(cl[,-rm.id.3.pos]) - } if(method == "cfe"){ for(ind.name in names(index.matrix)){ index.matrix[[ind.name]] <- as.matrix(index.matrix[[ind.name]][,-rm.id.3.pos]) @@ -1413,21 +1393,21 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } } - ## recover treatment indicators + ## recover treatment indicators D.pos <- NULL - ##DD <- D + ##DD <- D if (hasCarryover) { - D.pos <- which(D == 2) + D.pos <- which(D == 2) if (length(D.pos) > 0) { - D[D.pos] <- 0 - } + D[D.pos] <- 0 + } } - ## 8. Finally, check enough observations + ## 8. Finally, check enough observations if (min(apply(II, 1, sum)) == 0) { if (placeboTest == 1) { stop("Some periods do not have any observations. Please set a smaller range for placebo period.") - } + } else if(carryoverTest == 1) { stop("Some periods do not have any observations. Please set a smaller range for carryover period.") } @@ -1439,7 +1419,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if (min(apply(II, 2, sum)) == 0) { if (placeboTest == 1) { stop("Some units do not have any observations. Please set a smaller range for placebo period.") - } + } else if(carryoverTest == 1) { stop("Some units do not have any observations. Please set a smaller range for carryover period.") } @@ -1464,9 +1444,9 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) ## set seed if (is.null(seed) == FALSE) { set.seed(seed+1) - } + } } - + if ((se == TRUE | permute == TRUE) & parallel==TRUE) { ## set seed if (is.null(seed) == FALSE) { @@ -1482,110 +1462,112 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } message("Parallel computing ...\n") } - + ##-------------------------------## ## run main program - ##-------------------------------## + ##-------------------------------## if (se == FALSE) { - - if (CV == TRUE) { + + if (CV == TRUE) { if (binary == FALSE) { out <- fect.cv(Y = Y, D = D, X = X, W = W, - I = I, II = II, - T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, - T.on.balance = T.on.balance, + I = I, II = II, + T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, + T.on.balance = T.on.balance, balance.period = balance.period, method = method, criterion = criterion, k = k, cv.prop = cv.prop, cv.treat = cv.treat, - cv.nobs = cv.nobs, + cv.nobs = cv.nobs, cv.donut = cv.donut, min.T0 = min.T0, r = r, r.end = r.end, - proportion = proportion, + proportion = proportion, nlambda = nlambda, lambda = lambda, - force = force, hasRevs = hasRevs, - tol = tol, max.iteration = max.iteration, norm.para = norm.para, - group.level = g.level, group = G) - } + force = force, hasRevs = hasRevs, + tol = tol, max.iteration = max.iteration, norm.para = norm.para, + group.level = g.level, group = G, + HTEid = HTEid, moderator.type = moderator.type, moderator.nbins = moderator.nbins, HTE.enp.seq = HTE.enp.seq) + } else { - out <- fect.binary.cv(Y = Y, D = D, X = X, - I = I, II = II, - T.on = T.on, T.off = T.off, + out <- fect.binary.cv(Y = Y, D = D, X = X, + I = I, II = II, + T.on = T.on, T.off = T.off, k = k, cv.prop = cv.prop, - cv.treat = cv.treat, + cv.treat = cv.treat, cv.nobs = cv.nobs, - r = r, r.end = r.end, - QR = QR, force = force, + r = r, r.end = r.end, + QR = QR, force = force, hasRevs = hasRevs, tol = tol, group.level = g.level, group = G) } - - } + + } else { ## non-binary case if (method == "ife") { - out <- fect.fe(Y = Y, D = D, X = X, + out <- fect.fe(Y = Y, D = D, X = X, W = W, I = I, II = II, - T.on = T.on, T.off = T.off, r.cv = r, T.on.carry = T.on.carry, - T.on.balance = T.on.balance, + T.on = T.on, T.off = T.off, r.cv = r, T.on.carry = T.on.carry, + T.on.balance = T.on.balance, balance.period = balance.period, binary = binary, QR = QR, - force = force, hasRevs = hasRevs, + force = force, hasRevs = hasRevs, tol = tol , max.iteration = max.iteration, boot = 0, norm.para = norm.para, - placeboTest = placeboTest, + placeboTest = placeboTest, placebo.period = placebo.period, carryoverTest = carryoverTest, carryover.period = carryover.period, - group.level = g.level, group = G) + group.level = g.level, group = G, + HTEid = HTEid, moderator.type = moderator.type, moderator.nbins = moderator.nbins, HTE.enp.seq = HTE.enp.seq) } else if(method == "gsynth"){ - out <- fect.gsynth(Y = Y, D = D, X = X, + out <- fect.gsynth(Y = Y, D = D, X = X, W = W, I = I, II = II, - T.on = T.on, T.off = T.off, r = r, CV = 0, - T.on.balance = T.on.balance, + T.on = T.on, T.off = T.off, r = r, CV = 0, + T.on.balance = T.on.balance, balance.period = balance.period, binary = binary, QR = QR, - force = force, hasRevs = hasRevs, + force = force, hasRevs = hasRevs, tol = tol , max.iteration = max.iteration, boot = 0, norm.para = norm.para, - placeboTest = placeboTest, + placeboTest = placeboTest, placebo.period = placebo.period, carryoverTest = carryoverTest, carryover.period = carryover.period, - group.level = g.level, group = G) - } + group.level = g.level, group = G) + } else if (method == "mc") { - out <- fect.mc(Y = Y, D = D, X = X, + out <- fect.mc(Y = Y, D = D, X = X, W = W, I = I, II = II, - T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, - T.on.balance = T.on.balance, + T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, + T.on.balance = T.on.balance, balance.period = balance.period, lambda.cv = lambda, - force = force, hasRevs = hasRevs, + force = force, hasRevs = hasRevs, tol = tol , max.iteration = max.iteration, boot = 0, norm.para = norm.para, - placeboTest = placeboTest, + placeboTest = placeboTest, placebo.period = placebo.period, carryoverTest = carryoverTest, carryover.period = carryover.period, group.level = g.level, group = G) - } + } else if (method %in% c("polynomial", "cfe")) { - out <- fect.polynomial(Y = Y, D = D, X = X, - W = W, I = I, II = II, - T.on = T.on, T.on.carry = T.on.carry, - T.on.balance = T.on.balance, + out <- fect.polynomial(Y = Y, D = D, X = X, + W = W, I = I, II = II, + T.on = T.on, T.on.carry = T.on.carry, + T.on.balance = T.on.balance, balance.period = balance.period, T.off = T.off, method = method, degree = degree, sfe = sfe, cfe = cfe, ind.matrix = index.matrix, - knots = knots, force = force, - hasRevs = hasRevs, tol = tol , max.iteration = max.iteration, boot = 0, + knots = knots, force = force, + hasRevs = hasRevs, tol = tol , max.iteration = max.iteration, boot = 0, placeboTest = placeboTest, - placebo.period = placebo.period, + placebo.period = placebo.period, carryoverTest = carryoverTest, carryover.period = carryover.period, norm.para = norm.para, @@ -1602,14 +1584,14 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) I <- out$I II <- out$II } - + } - } + } else { # SE == TRUE - - out <- fect.boot(Y = Y, D = D, X = X, + + out <- fect.boot(Y = Y, D = D, X = X, W = W, I = I, II = II, - T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, cl = cl, + T.on = T.on, T.off = T.off, T.on.carry = T.on.carry, cl = NULL, T.on.balance = T.on.balance, balance.period = balance.period, method = method, degree = degree, sfe = sfe, cfe = cfe, @@ -1617,25 +1599,26 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) knots = knots, criterion = criterion, CV = CV, k = k, cv.prop = cv.prop, cv.treat = cv.treat, cv.nobs = cv.nobs, - r = r, r.end = r.end, + r = r, r.end = r.end, nlambda = nlambda, lambda = lambda, alpha = alpha, binary = binary, QR = QR, force = force, hasRevs = hasRevs, tol = tol , max.iteration = max.iteration, norm.para = norm.para, - placeboTest = placeboTest, + placeboTest = placeboTest, placebo.period = placebo.period, carryoverTest = carryoverTest, carryover.period = carryover.period, vartype = vartype, quantile.CI = quantile.CI, nboots = nboots, parallel = parallel, - cores = cores, group.level = g.level, group = G) + cores = cores, group.level = g.level, group = G, + HTEid = HTEid, moderator.type = moderator.type, moderator.nbins = moderator.nbins, HTE.enp.seq = HTE.enp.seq) if(method %in% c("polynomial", "cfe")){ I <- out$I II <- out$II } - + } @@ -1649,26 +1632,28 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) N_bar <- NULL ## leave one period out placebo test for pre-treatment periods - if (is.null(proportion)==TRUE) { - proportion <- 0 - } - max.count <- max(out$count) - - max.pre.periods <- out$time[which(out$count >= max.count * proportion & out$time <= 0)] - all.pre.periods <- out$time[which(out$time <= 0)] - if (is.null(pre.periods) == TRUE) { - pre.periods <- max.pre.periods - } - else { - pre.periods <- intersect(pre.periods[1]:pre.periods[length(pre.periods)], max.pre.periods) - } - pre.term <- pre.periods - N_bar <- max(out$count[which(out$time %in% pre.periods)]) - + # if (is.null(proportion)==TRUE) { + # proportion <- 0 + # } + # max.count <- max(out$count) + # max.pre.periods <- out$time[which(out$count >= max.count * proportion & out$time <= 0)] + # print(max.pre.periods) + # if (is.null(pre.periods) == TRUE) { + # pre.periods <- max.pre.periods + # } + # # else { + # # print(pre.periods) + # # if (length(pre.periods) > 0){ + # # pre.periods <- intersect(pre.periods[1]:pre.periods[length(pre.periods)], max.pre.periods) + # # } + # # } + # pre.term <- pre.periods + # N_bar <- max(out$count[which(out$time %in% pre.periods)]) + if (placeboEquiv == TRUE) { - pre.term <- all.pre.periods - r.cv <- out$r.cv - lambda.cv <- out$lambda.cv + + r.cv <- out$r.cv + lambda.cv <- out$lambda.cv method <- out$method if (method == "fe") { method <- "ife" @@ -1680,9 +1665,9 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) #} else { # pre.term.bound <- sort(placebo.period) # pre.term <- pre.term.bound[1]:pre.term.bound[length(pre.term.bound)] - #} + #} - placebo.period <- pre.term[1]:pre.term[length(pre.term)] + placebo.period <- pre.term[1]:pre.term[length(pre.term)] pre.est.att <- matrix(NA, length(pre.term), 6) pre.att.bound <- matrix(NA, length(pre.term), 2) @@ -1722,14 +1707,14 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) pre.term <- sort(pre.term, decreasing = TRUE) for (kk in pre.term) { - + placebo.pos <- which(T.on == kk) - pX <- X - pY <- Y - pD <- D - pI <- I - pII <- II + pX <- X + pY <- Y + pD <- D + pI <- I + pII <- II pT.on <- T.on pT.off <- T.off pG <- G @@ -1746,7 +1731,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) message(paste("All treated units have been removed for period ", kk, sep = "")) message("\n") jj <- jj - 1 - + } else { te <- paste("Pre-period ", kk, sep = "") @@ -1759,12 +1744,12 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) rem.id.new <- rem.id rm.id.2.pos <- sort(which(T0.2 < min.T0)) - rm.id.2 <- rem.id.new[rm.id.2.pos] + rm.id.2 <- rem.id.new[rm.id.2.pos] rem.id.2 <- setdiff(rem.id.new, rm.id.2) rem.id.new <- rem.id.2 rm.id.new <- setdiff(1:N, rem.id.new) - + if (length(rm.id.2) > 0) { X.old <- pX if (p > 0) { @@ -1783,9 +1768,9 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) pI <- as.matrix(I[,-rm.id.2.pos]) ## after removing pII <- as.matrix(II[,-rm.id.2.pos]) pT.on <- as.matrix(T.on[,-rm.id.2.pos]) - if (!is.null(cl)) { - p.cl <- cl[-rm.id.2.pos] - } + #if (!is.null(cl)) { + # cl <- cl[-rm.id.2.pos] + #} if(hasRevs){ pT.off <- as.matrix(T.off[,-rm.id.2.pos]) } @@ -1801,31 +1786,31 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } } - - p.out <- fect.boot(Y = pY, D = pD, X = pX, + + p.out <- fect.boot(Y = pY, D = pD, X = pX, W = pW, I = pI, II = pII, - T.on = pT.on, T.off = pT.off, cl = p.cl,T.on.carry = T.on.carry, + T.on = pT.on, T.off = pT.off, cl = NULL,T.on.carry = T.on.carry, method = method, degree = degree, knots = knots, criterion = criterion, CV = 0, k = k, cv.prop = cv.prop, cv.treat = cv.treat, cv.nobs = cv.nobs, - r = r.cv, r.end = r.end, + r = r.cv, r.end = r.end, nlambda = nlambda, lambda = lambda.cv, alpha = alpha, binary = binary, QR = QR, force = force, hasRevs = 0, tol = tol , max.iteration = max.iteration, norm.para = norm.para, - placeboTest = 0, + placeboTest = 0, placebo.period = NULL, carryoverTest = 0, carryover.period = NULL, vartype = vartype, nboots = nboots, parallel = parallel, quantile.CI = quantile.CI, - cores = cores, group.level = g.level, group = pG, + cores = cores, group.level = g.level, group = pG, dis = FALSE) - p.est.att <- p.out$est.att - p.att.bound <- p.out$att.bound + p.est.att <- p.out$est.att + p.att.bound <- p.out$att.bound p.pos <- which(as.numeric(rownames(p.est.att)) == kk) pre.est.att[jj, ] <- p.est.att[p.pos, ] @@ -1845,7 +1830,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) if(length(p.pos.sub)==1){ pre.est.att.group[[group.name]][pre.period.name,] <- p.est.att.sub[p.pos.sub,] pre.att.bound.group[[group.name]][pre.period.name,] <- p.att.bound.sub[p.pos.sub,] - pre.att.boot.group[[group.name]][pre.period.name,] <- p.att.boot.sub[p.pos.sub,] + pre.att.boot.group[[group.name]][pre.period.name,] <- p.att.boot.sub[p.pos.sub,] } } } @@ -1864,19 +1849,19 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) sub.output$pre.att.boot <- pre.att.boot.group[[group.name]] pre.est.group.output[[group.name]] <- sub.output } - } + } } - ## permutation test + ## permutation test if (permute == TRUE) { message("Permuting under sharp null hypothesis ... ") out.permute <- fect.permu(Y = Y, X = X, D = D, I = I, r.cv = out$r.cv, - lambda.cv = out$lambda.cv, m = m, + lambda.cv = out$lambda.cv, m = m, permu.dimension = permu.dimension, - method = out$method, degree = degree, - knots = knots, force = force, + method = out$method, degree = degree, + knots = knots, force = force, tol = tol, norm.para = norm.para, nboots = nboots, parallel = parallel, cores = cores) @@ -1887,7 +1872,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) } - + if ((se == TRUE | permute) & parallel == TRUE) { stopCluster(para.clusters) #closeAllConnections() @@ -1895,12 +1880,12 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) ## message("\nOK4\n") - - + + ##-------------------------------## ## storage - ##-------------------------------## - + ##-------------------------------## + iname.old <- iname <- unique(sort(data.old[,id])) ## tname.old <- tname <- unique(sort(data.old[,time])) if (!0%in%I.use) { @@ -1929,12 +1914,12 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) unit.type[i] <- 3 ## reversal } } - - # 1 treated - # 2 control - # 3 missing - # 4 removed - # 5 placebo or carryover + + # 1 treated + # 2 control + # 3 missing + # 4 removed + # 5 placebo or carryover obs.missing <- matrix(0, TT, N) ## not under treatment obs.missing[, rem.id] <- D + as.matrix(abs(I - 1)) * 3 ## under treatment obs.missing[which(obs.missing==0)] <- 2 @@ -1984,7 +1969,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) rownames(out$est.carryover) <- c("Carryover effect") } } - } + } colnames(out$eff) <- iname rownames(out$eff) <- tname out$eff.calendar <- cbind(matrix(out$eff.calendar,ncol=1),out$N.calendar) @@ -2041,30 +2026,30 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) carryover.period = carryover.period, unit.type = unit.type, obs.missing = obs.missing, - obs.missing.balance = obs.missing.balance), + obs.missing.balance = obs.missing.balance), out) - - + + if (1 %in% rm.id) { output <- c(output,list(remove.id = remove.id)) ## message("list of removed units:",remove.id) ## message("\n\n") - } - - #if (se == TRUE) { - # suppressWarnings(test.out <- diagtest(output, pre.periods = pre.periods, + } + + #if (se == TRUE) { + # suppressWarnings(test.out <- diagtest(output, pre.periods = pre.periods, # f.threshold = f.threshold, tost.threshold = tost.threshold)) # output <- c(output, list(test.out = test.out)) #} - - + + if (permute == TRUE) { output <- c(output,list(permute = permute.result)) } if (placeboEquiv == TRUE) { - output <- c(output, list(pre.est.att = pre.est.att, - pre.att.bound = pre.att.bound, + output <- c(output, list(pre.est.att = pre.est.att, + pre.att.bound = pre.att.bound, pre.att.boot = pre.att.boot, pre.est.group.output = pre.est.group.output)) } @@ -2072,32 +2057,32 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) # if (placeboEquiv || placeboTest || carryoverTest) { # classic equivalence test, placeboTest, and carryoverTest # this can also be used in placeboTest - - # classic equivalence test + + # this is the classic equivalence test if(loo==TRUE){ output$loo <- FALSE } if(se==1){ suppressWarnings( - test.out <- diagtest(output, pre.periods = pre.periods, - f.threshold = f.threshold, - tost.threshold = tost.threshold, + test.out <- diagtest(output, pre.periods = pre.periods, + f.threshold = f.threshold, + tost.threshold = tost.threshold, N_bar = N_bar) ) output <- c(output, list(test.out = test.out)) } - # loo equivalence test + # this is the loo equivalence test if(loo==TRUE){ output$loo <- TRUE } if(loo==TRUE && se == 1){ suppressWarnings( - test.out <- diagtest(output, pre.periods = pre.periods, - f.threshold = f.threshold, - tost.threshold = tost.threshold, + test.out <- diagtest(output, pre.periods = pre.periods, + f.threshold = f.threshold, + tost.threshold = tost.threshold, N_bar = N_bar) ) output <- c(output, list(loo.test.out = test.out)) @@ -2107,8 +2092,7 @@ fect.default <- function(formula = NULL, data, # a data frame (long-form) output <- c(output, list(call = match.call())) class(output) <- "fect" return(output) -} ## Program fect ends - +} ## Program fect ends diff --git a/R/fe.R b/R/fe.R index a09c787..8627a00 100644 --- a/R/fe.R +++ b/R/fe.R @@ -4,18 +4,18 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix X, # Explanatory variables: (T*N*p) array D, # Indicator for treated unit (tr==1) - W, + W, I, - II, - T.on, - T.off = NULL, - T.on.carry = NULL, + II, + T.on, + T.off = NULL, + T.on.carry = NULL, T.on.balance = NULL, balance.period = NULL, r.cv = 0, # initial number of factors considered if CV==1 binary = FALSE, - QR = FALSE, - force, + QR = FALSE, + force, hasRevs = 1, tol, # tolerance level max.iteration = 1000, @@ -35,11 +35,16 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix group.level = NULL, group = NULL, time.on.seq.group = NULL, - time.off.seq.group = NULL) { - + time.off.seq.group = NULL, + HTEid = NULL, + moderator.type = NULL, + moderator.nbins = 3, + HTE.enp.seq = NULL, + HTEbootVal = NULL) + { ##-------------------------------## ## Parsing data - ##-------------------------------## + ##-------------------------------## carryover.pos <- placebo.pos <- na.pos <- NULL res.sd1 <- res.sd2 <- NULL @@ -55,7 +60,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix ## replicate data YY <- Y - YY[which(II == 0)] <- 0 ## reset to 0 + YY[which(II == 0)] <- 0 ## reset to 0 D.c <- apply(D, 2, function(vec){cumsum(vec)}) D.c <- ifelse(D.c > 0, 1, 0) @@ -78,21 +83,21 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix initialOut <- Y0 <- beta0 <- FE0 <- xi0 <- factor0 <- NULL oci <- which(c(II) == 1) - if (binary == FALSE) { + if (binary == FALSE) { if(!is.null(W)){ initialOut <- initialFit(data = data.ini, force = force, w = c(W), oci = oci) }else{ initialOut <- initialFit(data = data.ini, force = force, w = NULL, oci = oci) } - + Y0 <- initialOut$Y0 beta0 <- initialOut$beta0 if (p > 0 && sum(is.na(beta0)) > 0) { beta0[which(is.na(beta0))] <- 0 } - + ## ini.res <- initialOut$res - } + } else { initialOut <- BiInitialFit(data = data.ini, QR = QR, r = r.cv, force = force, oci = oci) Y0 <- initialOut$Y0 @@ -103,11 +108,11 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix factor0 <- initialOut$factor0 } } - + ##-------------------------------## ## ----------- Main Algorithm ----------- ## ##-------------------------------## - + validX <- 1 ## no multi-colinearity est.fect <- NULL @@ -119,16 +124,16 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } if (binary == FALSE) { - est.best <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, r.cv, force = force, tol, max.iteration) + est.best <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, r.cv, force = force, tol, max.iteration) if (boot == FALSE) { if (r.cv == 0) { est.fect <- est.best - } + } else { est.fect <- inter_fe_ub(YY, Y0, X, II, W.use, beta0, 0, force = force, tol, max.iteration) } } - } + } else { if (QR == FALSE) { est.best <- inter_fe_d_ub(YY, Y0, FE0, X, II, r.cv, force, tol = tol) @@ -138,19 +143,19 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } validX <- est.best$validX validF <- ifelse(r.cv > 0, 1, 0) - + ##------------------------------## ## ----------- Summarize -------------- ## - ##------------------------------## + ##------------------------------## ##-------------------------------## ## ATT and Counterfactuals ## ##-------------------------------## - ## we first adjustment for normalization + ## we first adjustment for normalization if (!is.null(norm.para) && binary == FALSE) { Y <- Y * norm.para[1] - ## variance of the error term + ## variance of the error term sigma2 <- est.best$sigma2 * (norm.para[1]^2) IC <- est.best$IC - log(est.best$sigma2) + log(sigma2) PC <- est.best$PC * (norm.para[1]^2) @@ -159,23 +164,23 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix est.best$PC <- PC ## output of estimates - est.best$mu <- est.best$mu * norm.para[1] + est.best$mu <- est.best$mu * norm.para[1] if (r.cv > 0) { est.best$lambda <- est.best$lambda * norm.para[1] est.best$VNT <- est.best$VNT * norm.para[1] } if (force%in%c(1, 3)) { - est.best$alpha <- est.best$alpha * norm.para[1] + est.best$alpha <- est.best$alpha * norm.para[1] } if (force%in%c(2,3)) { - est.best$xi <- est.best$xi * norm.para[1] + est.best$xi <- est.best$xi * norm.para[1] } #if (p>0) { # est.best$beta <- est.best$beta * norm.para[1] #} - est.best$residuals <- est.best$residuals * norm.para[1] + est.best$residuals <- est.best$residuals * norm.para[1] est.best$fit <- est.best$fit * norm.para[1] - ## ini.res <- ini.res * norm.para[1] + ## ini.res <- ini.res * norm.para[1] if (boot == FALSE) { est.fect$fit <- est.fect$fit * norm.para[1] } @@ -185,7 +190,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix ## 0. relevant parameters IC <- est.best$IC if (binary == FALSE) { - sigma2 <- est.best$sigma2 + sigma2 <- est.best$sigma2 PC <- est.best$PC } else { loglikelihood <- est.best$loglikelihood @@ -200,7 +205,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } else { beta <- NA } - + ## 1. estimated att and counterfactuals Y.ct.equiv <- Y.ct <- NULL if (binary == FALSE) { @@ -211,7 +216,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } else { Y.ct <- pnorm(est.best$fit) } - eff <- Y - Y.ct + eff <- Y - Y.ct missing.index <- which(is.na(eff)) if(length(missing.index)>0){ I[missing.index] <- 0 @@ -219,7 +224,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } if (0 %in% I) { eff[which(I == 0)] <- NA - } + } complete.index <- which(!is.na(eff)) att.avg <- sum(eff[complete.index] * D[complete.index])/(sum(D[complete.index])) @@ -250,14 +255,14 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix tr.pos <- which(apply(D, 2, sum) > 0) att.unit <- sapply(1:length(tr.pos), function(vec){return(sum(eff[, tr.pos[vec]] * D[, tr.pos[vec]]) / sum(D[, tr.pos[vec]]))}) att.avg.unit <- mean(att.unit,na.rm=TRUE) - + equiv.att.avg <- eff.equiv <- NULL if (binary == FALSE && boot == FALSE) { eff.equiv <- Y - Y.ct.equiv if (0 %in% I) { eff.equiv[which(I == 0)] <- NA } - complete.index <- which(!is.na(eff.equiv)) + complete.index <- which(!is.na(eff.equiv)) equiv.att.avg <- sum(eff.equiv[complete.index] * D[complete.index])/(sum(D[complete.index])) } @@ -279,13 +284,13 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix est.best$fit[which(I == 0)] <- NA } if (binary == FALSE) { - est.best$residuals[which(II == 0)] <- NA + est.best$residuals[which(II == 0)] <- NA } - + ## 4. dynamic effects t.on <- c(T.on) - eff.v <- c(eff) ## a vector + eff.v <- c(eff) ## a vector eff.equiv.v <- NULL if (binary == FALSE && boot == FALSE) { eff.equiv.v <- c(eff.equiv) @@ -373,16 +378,16 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix att.on.sum.med.W <- att.on.sum.W <- count.on.med.W <- att.on.med.W <- W.on.sum.med <- att.on.W <- count.on.W <- time.on.W <- W.on.sum <- NULL } - ## 4.1 carryover effect - carry.att <- NULL + ## 4.1 carryover effect + carry.att <- NULL if (!is.null(T.on.carry)) { t.on.carry <- c(T.on.carry) - rm.pos4 <- which(is.na(t.on.carry)) + rm.pos4 <- which(is.na(t.on.carry)) t.on.carry.use <- t.on.carry if (NA %in% eff.v | NA %in% t.on.carry) { eff.v.use3 <- eff.v[-c(rm.pos1, rm.pos4)] - t.on.carry.use <- t.on.carry[-c(rm.pos1, rm.pos4)] + t.on.carry.use <- t.on.carry[-c(rm.pos1, rm.pos4)] } carry.time <- sort(unique(t.on.carry.use)) @@ -396,16 +401,16 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } } - ## 4.2 balance effect - balance.att <- NULL + ## 4.2 balance effect + balance.att <- NULL if (!is.null(balance.period)) { t.on.balance <- c(T.on.balance) - rm.pos4 <- which(is.na(t.on.balance)) + rm.pos4 <- which(is.na(t.on.balance)) t.on.balance.use <- t.on.balance if (NA %in% eff.v | NA %in% t.on.balance) { eff.v.use3 <- eff.v[-c(rm.pos1, rm.pos4)] - t.on.balance.use <- t.on.balance[-c(rm.pos1, rm.pos4)] + t.on.balance.use <- t.on.balance[-c(rm.pos1, rm.pos4)] } balance.time <- sort(unique(t.on.balance.use)) @@ -417,7 +422,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix balance.count.med <- rep(0, length(time.on.balance.seq)) balance.att.med[which(time.on.balance.seq %in% balance.time)] <- balance.att if(length(balance.count)>0){ - balance.count.med[which(time.on.balance.seq %in% balance.time)] <- balance.count + balance.count.med[which(time.on.balance.seq %in% balance.time)] <- balance.count } balance.count <- balance.count.med balance.att <- balance.att.med @@ -429,7 +434,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix if (length(placebo.period) == 1) { balance.placebo.pos <- which(balance.time == placebo.period) balance.att.placebo <- balance.att[balance.placebo.pos] - } + } else { balance.placebo.pos <- which(balance.time >= placebo.period[1] & balance.time <= placebo.period[2]) balance.att.placebo <- sum(balance.att[balance.placebo.pos] * balance.count[balance.placebo.pos]) / sum(balance.count[balance.placebo.pos]) @@ -437,12 +442,12 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } } - ## 5. placebo effect, if placeboTest == 1 - if (!is.null(placebo.period) && placeboTest == 1) { + ## 5. placebo effect, if placeboTest == 1 + if (!is.null(placebo.period) && placeboTest == 1) { if (length(placebo.period) == 1) { placebo.pos <- which(time.on == placebo.period) att.placebo <- att.on[placebo.pos] - } + } else { placebo.pos <- which(time.on >= placebo.period[1] & time.on <= placebo.period[2]) att.placebo <- sum(att.on[placebo.pos] * count.on[placebo.pos]) / sum(count.on[placebo.pos]) @@ -452,7 +457,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix if (length(placebo.period) == 1) { placebo.pos.W <- which(time.on.W == placebo.period) att.placebo.W <- att.on.W[placebo.pos.W] - } + } else { placebo.pos.W <- which(time.on.W >= placebo.period[1] & time.on.W <= placebo.period[2]) att.placebo.W <- sum(att.on.sum.W[placebo.pos.W]) / sum(W.on.sum[placebo.pos.W]) @@ -460,10 +465,10 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } } - + ## 6. switch-off effects eff.off.equiv <- off.sd <- eff.off <- NULL - if (hasRevs == 1) { + if (hasRevs == 1) { t.off <- c(T.off) rm.pos3 <- which(is.na(t.off)) eff.v.use2 <- eff.v @@ -511,7 +516,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } time.off.W <- sort(unique(t.off.use.W)) - att.off.sum.W <- as.numeric(tapply(eff.v.use2.W*W.v.use2, t.off.use.W, sum)) + att.off.sum.W <- as.numeric(tapply(eff.v.use2.W*W.v.use2, t.off.use.W, sum)) W.off.sum <- as.numeric(tapply(W.v.use2, t.off.use.W, sum)) att.off.W <- att.off.sum.W/W.off.sum ## NA already removed count.off.W <- as.numeric(table(t.off.use.W)) @@ -543,7 +548,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix if (length(carryover.period) == 1) { carryover.pos <- which(time.off == carryover.period) att.carryover <- att.off[carryover.pos] - } + } else { carryover.pos <- which(time.off >= carryover.period[1] & time.off <= carryover.period[2]) att.carryover <- sum(att.off[carryover.pos] * count.off[carryover.pos]) / sum(count.off[carryover.pos]) @@ -553,11 +558,11 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix if (length(carryover.period) == 1) { carryover.pos.W <- which(time.off.W == carryover.period) att.carryover.W <- att.off.W[carryover.pos.W] - } + } else { carryover.pos.W <- which(time.off.W >= carryover.period[1] & time.off.W <= carryover.period[2]) att.carryover.W <- sum(att.off.sum.W[carryover.pos.W]) / sum(W.off.sum[carryover.pos.W]) - } + } } } @@ -575,7 +580,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } } if(is.null(calendar.enp.seq)){ - loess.fit <- suppressWarnings(try(loess(eff.calendar~T.calendar,weights = N.calendar),silent=TRUE)) + loess.fit <- suppressWarnings(try(loess(eff.calendar~T.calendar,weights = N.calendar),silent=TRUE)) } else{ loess.fit <- suppressWarnings(try(loess(eff.calendar~T.calendar,weights = N.calendar,enp.target=calendar.enp.seq),silent=TRUE)) @@ -587,7 +592,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix else{ eff.calendar.fit <- eff.calendar eff.calendar.fit[which(!is.na(eff.calendar))] <- loess.fit$fit - calendar.enp <- loess.fit$enp + calendar.enp <- loess.fit$enp } } else{ @@ -596,9 +601,267 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } + ## 10. loess HTE by any variable + D.missing <- D + D.missing[which(D == 0)] <- NA + # if ((length(HTEid) != 1 | length(HTEid) == 0){ + # stop("not 1 variable for HTE") + # } + #generate variables for dynamic effects + att.on.HTE = list() + time.on.HTE = list() + count.on.HTE = list() + + + if(length(HTEid) == 1){ + HTEvalue = X[,,HTEid] + #check the key option moderator.type + if(!is.null(moderator.type)){ + if(! moderator.type %in% c("discrete","continuous")){ + stop("\"moderator.type\" option misspecified. Must be one of followings:\"discrete\",\"continuous\".") + } + } + else { + HTEuni = unique(as.vector(HTEvalue)) + if (length(HTEuni) > 5){ + moderator.type = "continuous" + } else{ + moderator.type = "discrete" + } + } + + if(moderator.type == "discrete"){ #代表离散型变量 + HTEuni = unique(as.vector(HTEvalue)) + # if(length(HTEbootVal) > 0){ + # HTEuni = HTEbootVal + # } + HTEuni <- sort(HTEuni) + avg.HTE <- rep(NA,length(HTEuni)) + N.HTE = rep(0,length(HTEuni)) + Ntr.HTE = rep(0,length(HTEuni)) + Val.HTE = HTEuni + for(i in c(1:length(HTEuni))){ + INDEX <- D.missing + INDEX[which(HTEvalue != HTEuni[i])] <- NA + avg.HTE[i] = mean(INDEX * eff, na.rm = TRUE) + Ntr.HTE[i] = length(INDEX) - length(which(is.na(INDEX))) + N.HTE[i] = length(which(HTEvalue == HTEuni[i])) + + #dynamic effects result storage + temp.index <- which(HTEvalue == HTEuni[i]) + temp.t.on = c(T.on[temp.index]) + temp.eff.v = c(eff[temp.index]) + temp.n.on = c(n.on.use[temp.index]) + + rm.pos1 <- which(is.na(temp.eff.v)) + rm.pos2 <- which(is.na(temp.t.on)) + + temp.eff.v.use1 <- temp.eff.v + temp.t.on.use <- temp.t.on + temp.n.on.use <- rep(1:N, each = TT) + if (NA %in% eff.v | NA %in% t.on) { + temp.eff.v.use1 <- temp.eff.v[-c(rm.pos1, rm.pos2)] + temp.t.on.use <- temp.t.on[-c(rm.pos1, rm.pos2)] + temp.n.on.use <- temp.n.on[-c(rm.pos1, rm.pos2)] + # if (binary == FALSE && boot == FALSE) { + # eff.equiv.v <- eff.equiv.v[-c(rm.pos1, rm.pos2)] + # } + } + + temp.time.on <- sort(unique(temp.t.on.use)) + temp.att.on <- as.numeric(tapply(temp.eff.v.use1, temp.t.on.use, mean)) ## NA already removed + temp.count.on <- as.numeric(table(temp.t.on.use)) + + if (!is.null(time.on.seq)) { + temp.count.on.med <- temp.att.on.med <- rep(NA, length(time.on.seq)) + temp.att.on.med[which(time.on.seq %in% temp.time.on)] <- temp.att.on + temp.count.on.med[which(time.on.seq %in% temp.time.on)] <- temp.count.on + temp.att.on <- temp.att.on.med + temp.count.on <- temp.count.on.med + temp.time.on <- time.on.seq + } + + att.on.HTE[[i]] = temp.att.on + time.on.HTE[[i]] = temp.time.on + count.on.HTE[[i]] = temp.count.on + + } + + # eff.HTE <- eff.HTE[which(N.HTE > 0)] #先把不存在treat对应值的情况删掉 + # Val.HTE <- Val.HTE[which(N.HTE > 0)] + # N.HTE <- N.HTE[which(N.HTE > 0)] + # N.HTE <- N.HTE[which(!is.na(eff.HTE))] #再删掉eff为na的情况 + # Val.HTE <- Val.HTE[which(!is.na(eff.HTE))] + # eff.HTE <- eff.HTE[which(!is.na(eff.HTE))] + # eff.HTE.fit <- eff.HTE + # HTE.enp <- NULL + } + if(moderator.type == "continuous"){ #代表连续型变量 + nbins = moderator.nbins + avg.HTE <- rep(NA,nbins) + N.HTE = rep(0,nbins) + Ntr.HTE = rep(0,nbins) + Val.HTE = rep(NA,nbins) + quan = 1/nbins + HTEquantile = quantile(HTEvalue,seq(quan,1,quan)) + + for(i in c(1:nbins)){ + INDEX <- D.missing + if (i == 1){ + INDEX[which((HTEvalue >= HTEquantile[i]))] <- NA + temp.index <- which(HTEvalue < HTEquantile[i]) + } + else if (i == nbins){ + INDEX[which((HTEvalue < HTEquantile[i - 1]))] <- NA + temp.index <- which(HTEvalue >= HTEquantile[i - 1]) + } + else { + INDEX[which((HTEvalue < HTEquantile[i - 1]) | HTEvalue >= HTEquantile[i])] <- NA + temp.index <- which((HTEvalue >= HTEquantile[i - 1]) & (HTEvalue < HTEquantile[i])) + } + avg.HTE[i] = mean(INDEX * eff, na.rm = TRUE) + Ntr.HTE[i] = length(INDEX) - length(which(is.na(INDEX))) + N.HTE[i] = length(temp.index) + Val.HTE[i] = quan * i + + temp.t.on = c(T.on[temp.index]) + temp.eff.v = c(eff[temp.index]) + + rm.pos1 <- which(is.na(temp.eff.v)) + rm.pos2 <- which(is.na(temp.t.on)) + + temp.eff.v.use1 <- temp.eff.v + temp.t.on.use <- temp.t.on + temp.n.on.use <- rep(1:N, each = TT) + if (NA %in% eff.v | NA %in% t.on) { + temp.eff.v.use1 <- temp.eff.v[-c(rm.pos1, rm.pos2)] + temp.t.on.use <- temp.t.on[-c(rm.pos1, rm.pos2)] + temp.n.on.use <- temp.n.on.use[-c(rm.pos1, rm.pos2)] + # if (binary == FALSE && boot == FALSE) { + # eff.equiv.v <- eff.equiv.v[-c(rm.pos1, rm.pos2)] + # } + } + + temp.time.on <- sort(unique(temp.t.on.use)) + temp.att.on <- as.numeric(tapply(temp.eff.v.use1, temp.t.on.use, mean)) ## NA already removed + temp.count.on <- as.numeric(table(temp.t.on.use)) + + if (!is.null(time.on.seq)) { + temp.count.on.med <- temp.att.on.med <- rep(NA, length(time.on.seq)) + temp.att.on.med[which(time.on.seq %in% temp.time.on)] <- temp.att.on + temp.count.on.med[which(time.on.seq %in% temp.time.on)] <- temp.count.on + temp.att.on <- temp.att.on.med + temp.count.on <- temp.count.on.med + temp.time.on <- time.on.seq + } + + att.on.HTE[[i]] = temp.att.on + time.on.HTE[[i]] = temp.time.on + count.on.HTE[[i]] = temp.count.on + } + # eff.HTE <- eff.HTE[which(N.HTE > 0)] #把不存在treat对应值的情况删掉 + # Val.HTE <- Val.HTE[which(N.HTE > 0)] + # N.HTE <- N.HTE[which(N.HTE > 0)] + + + HTEX <- HTEvalue[which(D == 1)] + HTEY <- eff[which(D == 1)] + # if(moderator.type == "discrete"){ + # bootVal = HTEuni + # HTEX <- as.factor(HTEX) + # } + # if(moderator.type == "continuous"){ + # bootVal = c(HTEmin,HTEmax) + # } + #regression for HTE estimate + #data_reg <- data.frame(HTEX,HTEY) + #REGout <- lm(HTEY ~ HTEX, data = data_reg) + #HTEcoef <- as.vector(REGout$coefficients[2]) + #print(HTEcoef) + } + + #loess fit for HTE + + if(!is.null(HTE.enp.seq)){ + if(length(HTE.enp.seq)==1 & is.na(HTE.enp.seq)){ + HTE.enp.seq <- NULL + } + } + if(is.null(HTE.enp.seq)){ + loess.HTE.fit <- suppressWarnings(try(loess(avg.HTE~Val.HTE,weights = N.HTE),silent=TRUE)) + } + else{ + loess.HTE.fit <- suppressWarnings(try(loess(avg.HTE~Val.HTE,weights = N.HTE,enp.target=HTE.enp.seq),silent=TRUE)) + } + + + if('try-error' %in% class(loess.HTE.fit)){ + avg.HTE.fit <- avg.HTE + HTE.enp <- NULL + } + else{ + avg.HTE.fit <- avg.HTE + avg.HTE.fit[which(!is.na(avg.HTE))] <- loess.HTE.fit$fit + HTE.enp <- loess.HTE.fit$enp + } + + if(is.null(avg.HTE.fit)){ + avg.HTE.fit <- avg.HTE + HTE.enp <- NULL + } + + } + else{ + avg.HTE = NULL + Val.HTE = NULL + N.HTE = NULL + Ntr.HTE = NULL + avg.HTE.fit = NULL + HTE.enp = NULL + bootVal = NULL + #HTEcoef = NULL + att.on.HTE = NULL + time.on.HTE = NULL + count.on.HTE = NULL + } + ##10.a dynamic effect by different groups + # if(moderator.type != 0){ + # stop("not seperate groups") + # } + # if(length(HTEuni) > 100){ + # stop("too many groups") + # } + # att.HTE.on <- list() + # time.HTE.on <- list() + # count.HTE.on <- list + # for(j in c(1:length(HTEuni))){ + # INDEX.temp <- which(HTEvalue == HTEuni[j]) + # t.on.temp <- c(T.on[INDEX.temp]) + # eff.v.temp <-c(eff[INDEX.temp]) + # rm.pos1 <- which(is.na(eff.v.temp)) + # rm.pos2 <- which(is.na(t.on.temp)) + # + # eff.v.use1.temp <- eff.v.temp + # t.on.use.temp <- t.on.temp + # n.on.use.temp <- rep(1:N, each = TT) + # if (NA %in% eff.v.temp | NA %in% t.on.temp) { + # eff.v.use1.temp <- eff.v.temp[-c(rm.pos1, rm.pos2)] + # t.on.use.temp <- t.on.temp[-c(rm.pos1, rm.pos2)] + # n.on.use.temp <- n.on.use.temp[-c(rm.pos1, rm.pos2)] + # } + # + # time.on.temp <- sort(unique(t.on.use.temp)) + # att.on.temp <- as.numeric(tapply(eff.v.use1.temp, t.on.use.temp, mean)) ## NA already removed + # count.on.temp <- as.numeric(table(t.on.use.temp)) + # + # time.HTE.on[[j]] <- time.on.temp + # att.HTE.on[[j]] <- att.on.temp + # count.HTE.on[[j]] <- count.on.temp + # } + ## 8. cohort effects if (!is.null(group)) { cohort <- cbind(c(group), c(D), c(eff.v)) @@ -623,7 +886,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix t.on.sub <- c(T.on[which(group==sub.group)]) eff.v.sub <- c(eff[which(group==sub.group)]) ## a vector rm.pos1.sub <- which(is.na(eff.v.sub)) - rm.pos2.sub <- which(is.na(t.on.sub)) + rm.pos2.sub <- which(is.na(t.on.sub)) eff.v.use1.sub <- eff.v.sub t.on.use.sub <- t.on.sub if (NA %in% eff.v.sub | NA %in% t.on.sub) { @@ -632,15 +895,15 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } if(length(t.on.use.sub)>0){ time.on.sub <- sort(unique(t.on.use.sub)) - att.on.sub <- as.numeric(tapply(eff.v.use1.sub, - t.on.use.sub, + att.on.sub <- as.numeric(tapply(eff.v.use1.sub, + t.on.use.sub, mean)) ## NA already removed count.on.sub <- as.numeric(table(t.on.use.sub)) } else{ time.on.sub <- att.on.sub <- count.on.sub <- NULL } - + if (!is.null(time.on.seq.group)) { count.on.med.sub <- att.on.med.sub <- rep(NA, length(time.on.seq.group[[sub.group.name]])) time.on.seq.sub <- time.on.seq.group[[sub.group.name]] @@ -657,28 +920,28 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix time.on=time.on.sub, count.on=count.on.sub) - ## placebo effect, if placeboTest == 1 - if (!is.null(placebo.period) && placeboTest == 1) { + ## placebo effect, if placeboTest == 1 + if (!is.null(placebo.period) && placeboTest == 1) { if (length(placebo.period) == 1) { placebo.pos.sub <- which(time.on.sub == placebo.period) if(length(placebo.pos.sub)>0){ att.placebo.sub <- att.on.sub[placebo.pos.sub] } - else{att.placebo.sub <- NULL} - } + else{att.placebo.sub <- NULL} + } else { placebo.pos.sub <- which(time.on.sub >= placebo.period[1] & time.on.sub <= placebo.period[2]) if(length(placebo.pos.sub)>0){ att.placebo.sub <- sum(att.on.sub[placebo.pos.sub] * count.on.sub[placebo.pos.sub]) / sum(count.on.sub[placebo.pos.sub]) } - else{att.placebo.sub <- NULL} + else{att.placebo.sub <- NULL} } if(length(att.placebo.sub)==0){att.placebo.sub <- NULL} suboutput <- c(suboutput, list(att.placebo = att.placebo.sub)) } ## T.off - if (hasRevs == 1) { + if (hasRevs == 1) { t.off.sub <- c(T.off[which(group==sub.group)]) rm.pos3.sub <- which(is.na(t.off.sub)) eff.v.use2.sub <- eff.v.sub @@ -716,12 +979,12 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix carryover.pos.sub <- which(time.off.sub == carryover.period) if(length(carryover.pos.sub)>0){ att.carryover.sub <- att.off.sub[carryover.pos.sub] - } else{att.carryover.sub <- NULL} + } else{att.carryover.sub <- NULL} } else { carryover.pos.sub <- which(time.off.sub >= carryover.period[1] & time.off.sub <= carryover.period[2]) if(length(carryover.pos.sub)>0){ att.carryover.sub <- sum(att.off.sub[carryover.pos.sub] * count.off.sub[carryover.pos.sub]) / sum(count.off.sub[carryover.pos.sub]) - } else{att.carryover.sub <- NULL} + } else{att.carryover.sub <- NULL} } if(length(att.carryover.sub)==0){att.carryover.sub <- NULL} suboutput <- c(suboutput,list(att.carryover = att.carryover.sub)) @@ -735,12 +998,13 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix method <- ifelse(r.cv > 0, "ife", "fe") - + ##-------------------------------## ## Storage ## - ##-------------------------------## + ##-------------------------------## + out<-list( - ## main results + ## main results method = method, Y.ct = Y.ct, Y.ct.full = Y.ct.full, @@ -761,8 +1025,8 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix tr = tr, co = co, p = p, - r.cv = r.cv, - IC = IC, + r.cv = r.cv, + IC = IC, beta = beta, est = est.best, mu = est.best$mu, @@ -778,19 +1042,36 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix calendar.enp = calendar.enp, eff.pre = eff.pre, eff.pre.equiv = eff.pre.equiv, - pre.sd = pre.sd) + pre.sd = pre.sd, + avg.HTE = avg.HTE, + Val.HTE = Val.HTE, + N.HTE = N.HTE, + Ntr.HTE = Ntr.HTE, + avg.HTE.fit = avg.HTE.fit, + HTE.enp = HTE.enp, + #bootVal = bootVal, + #HTEcoef = HTEcoef, + att.HTE = att.on.HTE, + time.HTE = time.on.HTE, + count.HTE = count.on.HTE, + moderator.type = moderator.type, + moderator.nbins = moderator.nbins + # time.HTE = time.HTE.on, + # att.HTE = att.HTE.on, + # count.HTE = count.HTE.on + ) if (binary == 0) { out <- c(out, list(PC = PC, sigma2 = sigma2, - sigma2.fect = est.fect$sigma2, + sigma2.fect = est.fect$sigma2, res = est.best$residuals, res.full = res.full, rmse = rmse)) #if (boot == FALSE) { # out <- c(out, list(equiv.att.avg = equiv.att.avg)) #} - } + } else { out <- c(out, list(loglikelihood = loglikelihood, marginal = marginal)) } @@ -800,14 +1081,14 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } if(!is.null(balance.period)){ - out <- c(out, list(balance.att = balance.att, balance.time = balance.time,balance.count = balance.count,balance.avg.att = att.avg.balance)) + out <- c(out, list(balance.att = balance.att, balance.time = balance.time,balance.count = balance.count,balance.avg.att = att.avg.balance)) if (!is.null(placebo.period) && placeboTest == 1) { out <- c(out, list(balance.att.placebo = balance.att.placebo)) - } + } } - + if (hasRevs == 1) { - out <- c(out, list(time.off = time.off, + out <- c(out, list(time.off = time.off, att.off = att.off, count.off = count.off, eff.off = eff.off, @@ -822,7 +1103,7 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix } if (force == 1) { - out<-c(out, list(alpha = est.best$alpha, + out<-c(out, list(alpha = est.best$alpha, alpha.tr = as.matrix(est.best$alpha[tr,]), alpha.co = as.matrix(est.best$alpha[co,]))) } else if (force == 2) { @@ -870,4 +1151,4 @@ fect.fe <- function(Y, # Outcome variable, (T*N) matrix group.output=group.output)) } return(out) -} ## fe functions ends. \ No newline at end of file +} ## fe functions ends. diff --git a/R/plot.R b/R/plot.R index bfc3c7f..1c21847 100644 --- a/R/plot.R +++ b/R/plot.R @@ -1,11 +1,11 @@ ## new plot # x: a fect object -# type of the plot; axes limits; axes labels; +# type of the plot; axes limits; axes labels; # main: whether to show the title; # id: plot a part of units -plot.fect <- function(x, - type = NULL, # gap, equiv, status, exit, factors, loadings, calendar, counterfactual +plot.fect <- function(x, + type = NULL, # gap, equiv, status, exit, factors, loadings, calendar, counterfactual,hte,gap.sub loo = FALSE, highlight = NULL, ## for carryover test and placebo test plot.ci = NULL, ## "0.9", "0.95", "none" @@ -23,9 +23,9 @@ plot.fect <- function(x, stats.labs = NULL, raw = "none", ## "none", "band", "all" main = NULL, - xlim = NULL, + xlim = NULL, ylim = NULL, - xlab = NULL, + xlab = NULL, ylab = NULL, gridOff = FALSE, legendOff = FALSE, @@ -40,7 +40,7 @@ plot.fect <- function(x, cex.main = NULL, cex.main.sub = NULL, cex.axis = NULL, - cex.lab = NULL, + cex.lab = NULL, cex.legend = NULL, cex.text = NULL, axis.adjust = FALSE, @@ -51,6 +51,8 @@ plot.fect <- function(x, return.test = FALSE, balance = NULL, weight = NULL, + moderator.loess = TRUE, + moderator = NULL, ...){ group <- ATT5 <- ATT6 <- CI.lower.90 <- CI.lower6 <- CI.upper.90 <- CI.upper6 <- L1 <- eff <- NULL @@ -96,7 +98,7 @@ plot.fect <- function(x, stop("No leave one out results for pre-treatment periods.") } else if(loo == TRUE && pequiv == TRUE){ - loo <- 1 + loo <- 1 } else{ loo <- 0 @@ -118,16 +120,16 @@ plot.fect <- function(x, if(!show.group%in%all.group.name){ message("The specified group does not exist or its treatment effects cannot be estimated.\n") return(0) - } + } } # check the key option type if(!is.null(type)){ if(type=="ct"){ - type <- "counterfactual" + type <- "counterfactual" } - if (!type %in% c("status", "gap","equiv","exit","factors","loadings","calendar","box","counterfactual")) { - stop("\"type\" option misspecified. Must be one of followings:\"status\",\"gap\",\"equiv\",\"exit\",\"calendar\",\"box\",\"counterfactual\".") + if (!type %in% c("status", "gap","equiv","exit","factors","loadings","calendar","box","counterfactual","hte","gap.sub")) { + stop("\"type\" option misspecified. Must be one of followings:\"status\",\"gap\",\"equiv\",\"exit\",\"calendar\",\"box\",\"counterfactual\",\"hte\",\"gap.sub\".") } if (type == "exit" && is.null(x$att.off)) { stop("No exiting treatment effect to be plotted.") @@ -156,20 +158,20 @@ plot.fect <- function(x, stop("Can't Visualize the Loadings.\n") } if (x$r.cv==0) { - stop("No factors are included in the model.\n") - } + stop("No factors are included in the model.\n") + } else { ## number of loadings to be plotted if (is.null(nfactors)==TRUE) { - nfactors<-min(x$r.cv,4) - } + nfactors<-min(x$r.cv,4) + } else if (nfactors>x$r.cv) { message("Too many factors specified. ") - nfactors<-min(x$r.cv,4) + nfactors<-min(x$r.cv,4) } if (nfactors == 1) { message("Loadings for the first factor are shown...\n") - } + } else if (nfactors < x$r.cv) { message(paste("Loadings for the first",nfactors,"factors are shown...\n")) } @@ -177,7 +179,7 @@ plot.fect <- function(x, ## title if (is.null(main) == TRUE) { main <- "Factor Loadings" - } + } else if (main=="") { main <- NULL } @@ -205,13 +207,13 @@ plot.fect <- function(x, "id"=c(x$tr, x$co), "group"=as.factor(c(rep("Treated",x$Ntr), rep("Control",x$Nco)))) - + if (nfactors == 1) { p <- ggplot(data, aes(x=group, y=L1, fill = group)) + geom_boxplot(alpha = 0.7) + coord_flip() + guides(fill=FALSE) + - xlab("") + ylab("Factor Loading") - } + xlab("") + ylab("Factor Loading") + } else { if (x$Ntr >= 5) { my_dens <- function(data, mapping, ...) { @@ -224,7 +226,7 @@ plot.fect <- function(x, diag = list(continuous = my_dens), title = main) + theme(plot.title = element_text(hjust = 0.5)) - } + } else if(x$Ntr > 1) { my_dens <- function(data, mapping, ...) { ggplot(data = data, mapping = mapping) + @@ -245,7 +247,7 @@ plot.fect <- function(x, columns = 1:nfactors, upper = 'blank', columnLabels = Llabel[1:nfactors], diag = list(continuous = my_dens), - title = main) + title = main) } } #suppressWarnings(print(p)) @@ -255,7 +257,7 @@ plot.fect <- function(x, if(type == "factors"){ if (theme.bw == TRUE) { line.color <- "#AAAAAA70" - } + } else { line.color <- "white" } @@ -263,7 +265,7 @@ plot.fect <- function(x, angle <- 45 x.v <- 1 x.h <- 1 - } + } else { angle <- 0 x.v <- 0 @@ -278,7 +280,7 @@ plot.fect <- function(x, stop("Can't Visualize the Loadings.\n") } if (x$r.cv==0) { - stop("No factors are included in the model.\n") + stop("No factors are included in the model.\n") } time <- x$rawtime @@ -287,7 +289,7 @@ plot.fect <- function(x, } if (length(xlim) != 0) { show <- which(time>=xlim[1]& time<=xlim[2]) - } + } else { show <- 1:length(time) } @@ -302,7 +304,7 @@ plot.fect <- function(x, if (x$r.cv==0) { message("No factors included in the model.\n") - } + } else { ## axes labels if (is.null(xlab)==TRUE) { @@ -323,7 +325,7 @@ plot.fect <- function(x, } ## prepare data L.co <- x$lambda.co - + if(x$force %in% c(2:3) & include.FE == TRUE){ L.co <- cbind(rep(1,dim(L.co)[1]),L.co) r.use <- c(0:(r-1)) @@ -336,7 +338,7 @@ plot.fect <- function(x, "factor" = c(F.hat[show,])*rep(norm,each=nT), "group" = as.factor(c(rep(r.use,each=nT)))) ## theme - p <- ggplot(data) + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -347,7 +349,7 @@ plot.fect <- function(x, plot.title = element_text(size=20, hjust = 0.5, face="bold", - margin = margin(10, 0, 10, 0))) + margin = margin(10, 0, 10, 0))) ## main plot p <- p + geom_line(aes(time, factor, colour = group, @@ -356,20 +358,20 @@ plot.fect <- function(x, brew.colors <- c("black","steelblue","#8DD3C7","#FFFFB3","#BEBADA","#FB8072","#80B1D3","#FDB462","#B3DE69","#FCCDE5","#D9D9D9") set.colors = brew.colors[1:r] - p <- p + scale_colour_manual(values =set.colors) + p <- p + scale_colour_manual(values =set.colors) ## legend - p <- p + guides(colour = guide_legend(title="Factor(s)", ncol=4)) + p <- p + guides(colour = guide_legend(title="Factor(s)", ncol=4)) if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } - + ## ylim if (is.null(ylim) == FALSE) { p <- p + coord_cartesian(ylim = ylim) - } + } #suppressWarnings(print(p)) return(p) } @@ -381,8 +383,8 @@ plot.fect <- function(x, if(!is.null(show.group)){ if(is.null(x$group.output[[show.group]]$att.on) & type!='status'){ stop(paste0(show.group, " doesn't contain treated units. Can't plot.\n")) - } - } + } + } if(type=='status' && !is.null(show.group)){ if(!is.null(id)){ @@ -411,14 +413,14 @@ plot.fect <- function(x, if(plot.ci == "0.95" && type=="equiv"){ warning("95% CI in equivalence test plots.\n") } - } + } else { # default settings for plot.ci if(is.null(x$est.att)){ plot.ci <- "none" } else if(type=='equiv'){ plot.ci <- "0.9" - } + } else { #gap plot or exiting plot plot.ci <- "0.95" } @@ -430,7 +432,7 @@ plot.fect <- function(x, if(plot.ci == "0.9"){ plot.ci <- "90" } - + if(type=='equiv' && plot.ci=='none'){ stop("No uncertainty estimates. Can't perform equivalence tests.\n") } @@ -476,7 +478,7 @@ plot.fect <- function(x, } else{ plot.ci.point <- plot.ci - } + } plot.ci <- "both" } @@ -491,7 +493,7 @@ plot.fect <- function(x, if (is.null(bound) == FALSE) { if (!bound %in% c("none", "min", "equiv", "both")) { stop("\"bound\" option misspecified.") - } + } } else{ # default settings for bound if(type=="equiv"){ @@ -524,17 +526,17 @@ plot.fect <- function(x, if (is.null(xlab)==FALSE) { if (is.character(xlab) == FALSE) { stop("\"xlab\" is not a string.") - } + } else { xlab <- xlab[1] - } + } } if (is.null(ylab)==FALSE) { if (is.character(ylab) == FALSE) { stop("\"ylab\" is not a string.") } else { ylab <- ylab[1] - } + } } if (!is.null(stats)) { @@ -543,21 +545,21 @@ plot.fect <- function(x, if (!stats[i] %in% c("none", "F.p", "F.equiv.p", "F.stat","equiv.p")) { stop ("Choose \"stats\" from c(\"none\", \"F.stat\", \"F.p\", \"F.equiv.p\", \"equiv.p\").") } - } - } + } + } else if(placeboTest) { for (i in 1:length(stats)) { if (!stats[i] %in% c("none", "placebo.p", "equiv.p")) { stop ("Choose \"stats\" from c(\"none\", \"placebo.p\", \"equiv.p\").") } - } + } } else if(carryoverTest){ # carry over test for (i in 1:length(stats)) { if (!stats[i] %in% c("none", "carryover.p", "equiv.p")) { stop ("Choose \"stats\" from c(\"none\", \"carryover.p\", \"equiv.p\").") } - } + } } if ("none" %in% stats) { stats <- "none" @@ -570,8 +572,8 @@ plot.fect <- function(x, } else { stats <- c("none") - } - } + } + } else if(type == 'equiv') { stats <- c("F.p","equiv.p") if (placeboTest == TRUE) { @@ -593,16 +595,23 @@ plot.fect <- function(x, if(type=='calendar'){ stats <- "none" } + if(type=='hte'){ + stats <- "none" + } + if(type=='gap.sub'){ + stats <- "none" + } + # names for all statistics if (!("none" %in% stats)) { if (is.null(stats.labs)==FALSE) { if (length(stats.labs)!=length(stats)) { stop("\"stats.lab\" should have the same length as \"stats\".") - } - } + } + } else { - stats.labs <- rep(NA, length(stats)) + stats.labs <- rep(NA, length(stats)) for (i in 1:length(stats)) { if (stats[i] == "F.p") { stats.labs[i] <- "F test p-value" @@ -648,21 +657,21 @@ plot.fect <- function(x, if (is.null(x$est.att)) { stop("No uncertainty estimates.\n") } - + # classic equivalence test if (length(xlim)==0) { xlim <- c(-1e5, 0) - } + } else { if (xlim[2]>0) { xlim[2] <- 0 } } - if (loo==0) { - maintext <- "Equivalence Test" + if (loo==0) { + maintext <- "Equivalence Test" #ytitle <- paste("Residual Average of",x$Y) - ytitle <- paste("Effect on",x$Y) - } + ytitle <- paste("Effect on",x$Y) + } else { # loo equivalence test maintext <- "Leave-one-out Equivalence Test" @@ -684,6 +693,10 @@ plot.fect <- function(x, maintext <- "Individual Treatment Effects" ytitle <- paste("Effect on",x$Y) } + else if (type == 'hte'){ + maintext <- "ATT by Moderator" + ytitle <- paste("Effect on",x$y) + } if (is.logical(legendOff) == FALSE & is.numeric(legendOff)==FALSE) { stop("\"legendOff\" is not a logical flag.") @@ -697,7 +710,7 @@ plot.fect <- function(x, stop("\"main\" is not a string.") } else { main <- main[1] - } + } } if (axis.adjust == TRUE) { angle <- 45 @@ -860,24 +873,24 @@ plot.fect <- function(x, if (!is.null(x$est.att)) { # have uncertainty estimation - est.att <- x$est.att + est.att <- x$est.att est.bound <- x$att.bound - - colnames(est.bound) <- c("CI.lower.90", "CI.upper.90") ## 90% ci + + colnames(est.bound) <- c("CI.lower.90", "CI.upper.90") ## 90% ci est.att <- cbind(est.att, est.bound) pre.est.att <- pre.att.bound <- NULL - if (loo==1) { ## replace pre-treatment period with loo results + if (loo==1) { ## replace pre-treatment period with loo results pre.est.att <- x$pre.est.att - pre.att.bound <- x$pre.att.bound + pre.att.bound <- x$pre.att.bound colnames(pre.att.bound) <- c("CI.lower.90", "CI.upper.90") ## 90% ci pre.est.att <- cbind(pre.est.att, pre.att.bound) - t0 <- t1 <- NULL + t0 <- t1 <- NULL t.s <- t.e <- NULL t0 <- rownames(pre.est.att) t1 <- rownames(est.att) t.s <- which(t1 == t0[1]) t.e <- which(t1 == t0[length(t0)]) - est.att[t.s:t.e ,] <- pre.est.att + est.att[t.s:t.e ,] <- pre.est.att } } @@ -886,7 +899,7 @@ plot.fect <- function(x, if(!is.null(x$est.att.off)){ est.att.off <- x$est.att.off est.bound.off <- x$att.off.bound - colnames(est.bound.off) <- c("CI.lower.90", "CI.upper.90") ## 90% ci + colnames(est.bound.off) <- c("CI.lower.90", "CI.upper.90") ## 90% ci est.att.off <- cbind(est.att.off, est.bound.off) } @@ -901,17 +914,17 @@ plot.fect <- function(x, } scaleFUN <- function(x) sprintf("%.f", x) ## integer value at x axis - + if (! raw %in% c("none","band","all")) { cat("\"raw\" option misspecifed. Reset to \"none\".") - raw <- "none" + raw <- "none" } if (is.null(id)==FALSE) { if (length(id)>1) { - stop("More than 1 element in \"id\".") + stop("More than 1 element in \"id\".") } } - + if (axis.adjust==TRUE) { angle <- 45 x.v <- 1 @@ -934,14 +947,14 @@ plot.fect <- function(x, Y.ct <- x$Y.ct D <- x$D.dat rawid <- x$id - + # time name time <- x$rawtime TT <- dim(Y)[1] if (!is.numeric(time[1])) { time <- 1:TT } - + #names(tr) <- id #names(co) <- id names(I) <- rawid @@ -958,7 +971,7 @@ plot.fect <- function(x, row.names(D) <- time #I.tr <- x$I.tr I.tr <-as.matrix(I[,tr]) - II.tr <- as.matrix(II[,tr]) + II.tr <- as.matrix(II[,tr]) #D.tr <- x$D.tr D.tr <-as.matrix(D[,tr]) #Y.tr <- x$Y.tr @@ -967,7 +980,7 @@ plot.fect <- function(x, Y.co <-Y[,co] #Y.ct <- x$Y.ct Y.ct <-as.matrix(Y.ct[,tr]) - + ## 3. unbalanced output? # Y.ct.full <- Y.ct # res.full <- Y - Y.ct @@ -976,65 +989,65 @@ plot.fect <- function(x, # Y.ct[which(I == 0)] <- NA # } # if (binary == FALSE) { - # res.full[which(II == 0)] <- NA + # res.full[which(II == 0)] <- NA # } - + ###### tb <- x$est.att #Yb <- x$Y.bar[,1:2] ## treated average and counterfactual average Yb <- cbind(apply(Y.tr,1,mean),apply(Y.ct,1,mean)) #tr <- x$tr #pre <- x$pre #post <- x$post - - + + if (!0%in%I.tr) { ## a (TT*Ntr) matrix, time dimension: before treatment pre <- as.matrix(D.tr == 0 & II.tr == 1) post <- as.matrix(!(D.tr == 0 & II.tr == 1)) - } + } else { pre <- as.matrix(D.tr == 0 & I.tr == 1 & II.tr == 1) post <- as.matrix(!(D.tr == 0 & I.tr == 1 & II.tr == 1)) - } - + } + Ntr <- x$Ntr Nco <- x$Nco - N <- x$N - + N <- x$N + # Generate out.gsynth.tr/co tr <- 1:N %in% tr names(tr) <- x$id co <- 1:N %in% co names(co) <- x$id - + # I.tr <- x$I.tr #TT <- x$T TT <- x$T #T0 <- x$T0 ## notice - T0 <- apply(pre, 2, sum) + T0 <- apply(pre, 2, sum) sameT0 <- length(unique(T0)) == 1 #p <- x$p p <- x$p ## m <- x$m - + ## time.label <- x$time ## T.b <- 1:TT - + #if (is.null(id)==TRUE) { #id <- id.tr #} - - + + ## parameters line.width <- c(1.2,0.5) - + ## color of axes if (theme.bw == TRUE) { line.color <- "#AAAAAA70" } else { line.color <- "white" } - + ## shade in the post-treatment period if (is.null(shade.post) == TRUE) { if (type %in% c("counterfactual","ct")) { @@ -1045,7 +1058,7 @@ plot.fect <- function(x, stop("Wrong type for option \"shade.post\"") } } - + id.tr <- rawid[tr] id.co <- rawid[co] ## type of plots @@ -1054,24 +1067,24 @@ plot.fect <- function(x, } else { time.bf <- time[unique(T0)] } - + ## periods to show if (length(xlim) != 0) { show <- which(time>=xlim[1]& time<=xlim[2]) } else { show <- 1:length(time) - } - - + } + + nT <- length(show) time.label <- time[show] - + ## if (axis.adjust==FALSE) { ## n.period <- length(show) ## } else { ## n.period <- length(show) ## min(length(show),20) ## } - + ## if (axis.adjust==TRUE) { ## n.period <- n.period - 1 ## T.n <- (nT-1)%/%n.period @@ -1088,8 +1101,8 @@ plot.fect <- function(x, ## } else { T.b <- 1:length(show) ## } - - + + ## legend on/off if (legendOff == TRUE) { legend.pos <- "none" @@ -1098,18 +1111,18 @@ plot.fect <- function(x, } #################################### - + ############ START ############### - if (length(id) == 1|length(id.tr) == 1|sameT0==TRUE) { - if (length(id) == 1) { + if (length(id) == 1|length(id.tr) == 1|sameT0==TRUE) { + if (length(id) == 1) { if(!id[1]%in%id.tr){ ## error stop(paste(id,"not in the treatment group")) } - } + } ## one treated unit case - + ## axes labels if (is.null(xlab)==TRUE) { xlab <- x$index[2] @@ -1121,25 +1134,25 @@ plot.fect <- function(x, } else if (ylab == "") { ylab <- NULL } - + ############### # If single treated unit case if (length(id) == 1 | length(id.tr) == 1) { ## one treated unit - + if (is.null(id) == TRUE) { id <- id.tr } - maintext <- paste("Treated and Counterfactual (",id,")",sep="") + maintext <- paste("Treated and Counterfactual (",id,")",sep="") tr.info <- Y.tr[,which(id==id.tr)] - ct.info <- Y.ct[,which(id==id.tr)] - if (raw == "none") { + ct.info <- Y.ct[,which(id==id.tr)] + if (raw == "none") { data <- cbind.data.frame("time" = rep(time[show],2), "outcome" = c(tr.info[show], ct.info[show]), "type" = c(rep("tr",nT), rep("ct",nT))) ## theme - p <- ggplot(data) + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1150,16 +1163,16 @@ plot.fect <- function(x, plot.title = element_text(size=20, hjust = 0.5, face="bold", - margin = margin(10, 0, 10, 0))) + margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) - } - + p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) + } + ## main p <- p + geom_line(aes(time, outcome, colour = type, size = type, - linetype = type)) + linetype = type)) ## legend set.limits = c("tr","ct") set.labels = c("Treated", "Estimated Y(0)") @@ -1178,31 +1191,31 @@ plot.fect <- function(x, guides(linetype = guide_legend(title=NULL, ncol=2), colour = guide_legend(title=NULL, ncol=2), size = guide_legend(title=NULL, ncol=2)) - + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) } - - - } + + + } else if (raw == "band") { - - Y.co.90 <- t(apply(Y.co, 1, quantile, prob=c(0.05,0.95), na.rm = TRUE)) + + Y.co.90 <- t(apply(Y.co, 1, quantile, prob=c(0.05,0.95), na.rm = TRUE)) data <- cbind.data.frame("time" = rep(time[show],2), "outcome" = c(tr.info[show], ct.info[show]), "type" = c(rep("tr",nT), rep("ct",nT))) - + data.band <- cbind.data.frame(time, Y.co.90)[show,] colnames(data.band) <- c("time","co5","co95") - - - ## theme - p <- ggplot(data) + + + ## theme + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1215,30 +1228,30 @@ plot.fect <- function(x, face="bold", margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) - } - + p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) + } + ## main p <- p + geom_line(aes(time, outcome, colour = type, size = type, linetype = type)) - + ## band p <- p + geom_ribbon(data = data.band, aes(ymin = co5, ymax = co95, x=time), alpha = 0.15, fill = "steelblue") - + set.limits <- c("tr","co.band","ct") set.labels <- c("Treated", "Controls (5-95% Quantiles)", "Estimated Y(0)") set.colors <- c("black","#4682B480","steelblue") set.linetypes <- c("solid","solid","longdash") set.linewidth <- c(line.width[1],4,line.width[1]) - + p <- p + scale_colour_manual(limits = set.limits, labels = set.labels, - values =set.colors) + + values =set.colors) + scale_linetype_manual(limits = set.limits, labels = set.labels, values = set.linetypes) + @@ -1247,18 +1260,18 @@ plot.fect <- function(x, values = set.linewidth) + guides(linetype = guide_legend(title=NULL, ncol=3), colour = guide_legend(title=NULL, ncol=3), - size = guide_legend(title=NULL, ncol=3)) - + size = guide_legend(title=NULL, ncol=3)) + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) } - - } + + } else if (raw == "all") { ## plot all the raw data - + data <- cbind.data.frame("time" = rep(time[show],(2 + Nco)), "outcome" = c(tr.info[show], ct.info[show], @@ -1269,9 +1282,9 @@ plot.fect <- function(x, "id" = c(rep("tr",nT), rep("ct",nT), rep(c(id.co), each = nT))) - + ## theme - p <- ggplot(data) + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1284,22 +1297,22 @@ plot.fect <- function(x, face="bold", margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) - } + p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) + } ## main p <- p + geom_line(aes(time, outcome, colour = type, size = type, linetype = type, group = id)) - + ## legend set.limits = c("tr","raw.co","ct") set.labels = c("Treated","Controls","Estimated Y(0)") set.colors = c("black","#4682B420","steelblue") set.linetypes = c("solid","solid","longdash") set.linewidth = c(line.width[1],line.width[2],line.width[1]) - + p <- p + scale_colour_manual(limits = set.limits, labels = set.labels, values =set.colors) + @@ -1311,18 +1324,18 @@ plot.fect <- function(x, values = set.linewidth) + guides(linetype = guide_legend(title=NULL, ncol=3), colour = guide_legend(title=NULL, ncol=3), - size = guide_legend(title=NULL, ncol=3)) - + size = guide_legend(title=NULL, ncol=3)) + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) - } - - } - - } + } + + } + + } else { # begin multiple treated unit case maintext <- "Treated and Counterfactual Averages" if (raw == "none") { @@ -1330,9 +1343,9 @@ plot.fect <- function(x, "outcome" = c(Yb[show,1], Yb[show,2]), "type" = c(rep("tr",nT), - rep("co",nT))) + rep("co",nT))) ## theme - p <- ggplot(data) + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1345,14 +1358,14 @@ plot.fect <- function(x, face="bold", margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) - } + p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) + } ## main p <- p + geom_line(aes(time, outcome, colour = type, size = type, linetype = type)) - + ## legend set.limits = c("tr","co") set.labels = c("Treated Average", @@ -1371,31 +1384,31 @@ plot.fect <- function(x, values = set.linewidth) + guides(linetype = guide_legend(title=NULL, ncol=2), colour = guide_legend(title=NULL, ncol=2), - size = guide_legend(title=NULL, ncol=2)) - + size = guide_legend(title=NULL, ncol=2)) + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) } - + } else if (raw == "band") { - + Y.tr.90 <- t(apply(Y.tr, 1, quantile, prob=c(0.05,0.95),na.rm=TRUE)) Y.co.90 <- t(apply(Y.co, 1, quantile, prob=c(0.05,0.95),na.rm=TRUE)) - + data <- cbind.data.frame("time" = rep(time[show],2), "outcome" = c(Yb[show,1], Yb[show,2]), "type" = c(rep("tr",nT), rep("co",nT))) - + data.band <- cbind.data.frame(time, Y.tr.90, Y.co.90)[show,] colnames(data.band) <- c("time","tr5","tr95","co5","co95") - - ## theme - p <- ggplot(data) + + ## theme + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1408,8 +1421,8 @@ plot.fect <- function(x, face="bold", margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf, ymin=-Inf, ymax=Inf, alpha = .3) - } + p <- p + annotate("rect", xmin= time.bf, xmax= Inf, ymin=-Inf, ymax=Inf, alpha = .3) + } ## main p <- p + geom_line(aes(time, outcome, colour = type, @@ -1422,7 +1435,7 @@ plot.fect <- function(x, geom_ribbon(data = data.band, aes(ymin = co5, ymax = co95, x=time), alpha = 0.15, fill = "steelblue") - + set.limits = c("tr","co","tr.band","co.band") set.labels = c("Treated Average", "Estimated Y(0) Average", @@ -1431,7 +1444,7 @@ plot.fect <- function(x, set.colors = c("black","steelblue","#77777750","#4682B480") set.linetypes = c("solid","longdash","solid","solid") set.linewidth = c(rep(line.width[1],2),4,4) - + p <- p + scale_colour_manual(limits = set.limits, labels = set.labels, values =set.colors) + @@ -1443,17 +1456,17 @@ plot.fect <- function(x, values = set.linewidth) + guides(linetype = guide_legend(title=NULL, ncol=2), colour = guide_legend(title=NULL, ncol=2), - size = guide_legend(title=NULL, ncol=2)) - + size = guide_legend(title=NULL, ncol=2)) + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) } - + } else if (raw == "all") { ## plot all the raw data - + data <- cbind.data.frame("time" = rep(time[show],(2 + N)), "outcome" = c(Yb[show,1], Yb[show,2], @@ -1466,9 +1479,9 @@ plot.fect <- function(x, "id" = c(rep("tr",nT), rep("co",nT), rep(c(id.tr,id.co), - each = nT))) + each = nT))) ## theme - p <- ggplot(data) + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1479,10 +1492,10 @@ plot.fect <- function(x, plot.title = element_text(size=20, hjust = 0.5, face="bold", - margin = margin(10, 0, 10, 0))) + margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) - } + p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) + } ## main p <- p + geom_line(aes(time, outcome, colour = type, @@ -1498,7 +1511,7 @@ plot.fect <- function(x, set.colors = c("black","steelblue","#77777750","#4682B420") set.linetypes = c("solid","longdash","solid","solid") set.linewidth = rep(line.width,each=2) - + p <- p + scale_colour_manual(limits = set.limits, labels = set.labels, values =set.colors) + @@ -1510,31 +1523,31 @@ plot.fect <- function(x, values = set.linewidth) + guides(linetype = guide_legend(title=NULL, ncol=2), colour = guide_legend(title=NULL, ncol=2), - size = guide_legend(title=NULL, ncol=2)) - + size = guide_legend(title=NULL, ncol=2)) + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) } } - + } # end multiple treated unit case - + ## title if (is.null(main) == TRUE) { p <- p + ggtitle(maintext) } else if (main!="") { p <- p + ggtitle(main) } - + ## ylim if (is.null(ylim) == FALSE) { p <- p + coord_cartesian(ylim = ylim) - } - - } + } + + } else { maintext <- "Treated and Counterfactual Averages" ## axes labels @@ -1548,9 +1561,9 @@ plot.fect <- function(x, } else if (ylab == "") { ylab <- NULL } - + ct.adjsut <- function (Y.tr, - Y.ct, + Y.ct, T0) { T <- dim(Y.tr)[1] N <- dim(Y.tr)[2] @@ -1571,16 +1584,16 @@ plot.fect <- function(x, Y.tr.aug=Y.tr.aug, Y.ct.aug=Y.ct.aug, Yb=Yb)) - - } + + } xx <- ct.adjsut(Y.tr, Y.ct, T0) - + time <- xx$timeline Yb <- xx$Yb Y.tr.aug <- xx$Y.tr.aug ## Y.ct.aug <- xx$Y.ct.aug time.bf <- 0 ## before treatment - + if (!is.null(xlim)) { show <- which(time>=xlim[1]& time<=xlim[2]) } else { @@ -1592,9 +1605,9 @@ plot.fect <- function(x, "outcome" = c(Yb[show,1], Yb[show,2]), "type" = c(rep("tr",nT), - rep("co",nT))) + rep("co",nT))) ## theme - p <- ggplot(data) + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1607,14 +1620,14 @@ plot.fect <- function(x, face="bold", margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) - } + p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) + } ## main p <- p + geom_line(aes(time, outcome, colour = type, size = type, linetype = type)) - + ## legend set.limits = c("tr","co") set.labels = c("Treated Average", @@ -1633,31 +1646,31 @@ plot.fect <- function(x, values = set.linewidth) + guides(linetype = guide_legend(title=NULL, ncol=2), colour = guide_legend(title=NULL, ncol=2), - size = guide_legend(title=NULL, ncol=2)) - + size = guide_legend(title=NULL, ncol=2)) + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) } - + } else if (raw == "band") { - + Y.tr.90 <- t(apply(Y.tr.aug, 1, quantile, prob=c(0.05,0.95),na.rm=TRUE)) ## Y.co.90 <- t(apply(Y.co, 1, quantile, prob=c(0.05,0.95),na.rm=TRUE)) - + data <- cbind.data.frame("time" = rep(time[show],2), "outcome" = c(Yb[show,1], Yb[show,2]), "type" = c(rep("tr",nT), rep("co",nT))) - + data.band <- cbind.data.frame(time, Y.tr.90)[show,] colnames(data.band) <- c("time","tr5","tr95") - + ## theme - p <- ggplot(data) + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1670,8 +1683,8 @@ plot.fect <- function(x, face="bold", margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) - } + p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) + } ## main p <- p + geom_line(aes(time, outcome, colour = type, @@ -1681,7 +1694,7 @@ plot.fect <- function(x, p <- p + geom_ribbon(data = data.band, aes(ymin = tr5, ymax = tr95, x=time), alpha = 0.15, fill = "red") - + set.limits = c("tr","co","tr.band") set.labels = c("Treated Average", "Estimated Y(0) Average", @@ -1689,7 +1702,7 @@ plot.fect <- function(x, set.colors = c("black","steelblue","#77777750") set.linetypes = c("solid","longdash","solid") set.linewidth = c(rep(line.width[1],2),4) - + p <- p + scale_colour_manual(limits = set.limits, labels = set.labels, values =set.colors) + @@ -1702,16 +1715,16 @@ plot.fect <- function(x, guides(linetype = guide_legend(title=NULL, ncol=2), colour = guide_legend(title=NULL, ncol=2), size = guide_legend(title=NULL, ncol=2)) - + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) - } - + } + } else if (raw == "all") { ## plot all the raw data - + data <- cbind.data.frame("time" = rep(time[show],(2 + Ntr)), "outcome" = c(Yb[show,1], Yb[show,2], @@ -1722,9 +1735,9 @@ plot.fect <- function(x, "id" = c(rep("tr",nT), rep("co",nT), rep(c(id.tr), - each = nT))) + each = nT))) ## theme - p <- ggplot(data) + p <- ggplot(data) if (theme.bw == TRUE) { p <- p + theme_bw() } @@ -1735,10 +1748,10 @@ plot.fect <- function(x, plot.title = element_text(size=20, hjust = 0.5, face="bold", - margin = margin(10, 0, 10, 0))) + margin = margin(10, 0, 10, 0))) if (shade.post == TRUE) { - p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) - } + p <- p + annotate("rect", xmin= time.bf, xmax= Inf,ymin=-Inf, ymax=Inf, alpha = .3) + } ## main p <- p + geom_line(aes(time, outcome, colour = type, @@ -1753,7 +1766,7 @@ plot.fect <- function(x, set.colors = c("black","steelblue","#77777750") set.linetypes = c("solid","longdash","solid") set.linewidth = c(rep(line.width[1],2),line.width[2]) - + p <- p + scale_colour_manual(limits = set.limits, labels = set.labels, values =set.colors) + @@ -1765,29 +1778,29 @@ plot.fect <- function(x, values = set.linewidth) + guides(linetype = guide_legend(title=NULL, ncol=2), colour = guide_legend(title=NULL, ncol=2), - size = guide_legend(title=NULL, ncol=2)) - + size = guide_legend(title=NULL, ncol=2)) + if (!is.numeric(time.label)) { - p <- p + + p <- p + scale_x_continuous(expand = c(0, 0), breaks = show[T.b], labels = time.label[T.b]) } else { p <- p + scale_x_continuous(labels=scaleFUN) } } - + ## title if (is.null(main) == TRUE) { p <- p + ggtitle(maintext) } else if (main!="") { p <- p + ggtitle(main) } - + ## ylim if (is.null(ylim) == FALSE) { p <- p + coord_cartesian(ylim = ylim) - } + } } - return(p) + return(p) } @@ -1859,28 +1872,28 @@ plot.fect <- function(x, } } - ## periods to show + ## periods to show time.end <- length(time) - show.time <- 1:time.end + show.time <- 1:time.end if (length(xlim) != 0) { show.time <- which(time >= xlim[1] & time <= xlim[2]) } if (type %in% c("gap","equiv","exit")) { if (is.null(proportion) == TRUE) { show.count <- 1:time.end - } - else { + } + else { show.count <- which(count.num >= max.count * proportion) } # which periods to be shown - show <- intersect(show.count, show.time) + show <- intersect(show.count, show.time) # maximum number of cases to be shown max.count <- max(count.num[show]) - + # where on x-axis to show the number max.count.pos <- time[intersect(show,which(count.num == max.count))] - + if (length(max.count.pos)>1) { if (best.pos %in% max.count.pos) { max.count.pos <- best.pos @@ -1890,19 +1903,19 @@ plot.fect <- function(x, max.count.pos <- max.count.pos[1] } } - } + } else { show <- show.time } if (length(show) < 2 & type %in% c("gap","equiv","exit")) { stop("Cannot plot.\n") - } - + } + nT <- length(show) time.label <- tname[show] T.b <- 1:length(show) - + ## legend on/off if (legendOff == TRUE) { legend.pos <- "none" @@ -1932,14 +1945,14 @@ plot.fect <- function(x, else{ switch.on <- TRUE } - + ## axes labels if (is.null(xlab) == TRUE) { if (switch.on == TRUE) { xlab <- paste("Time since the Treatment Began") } else { xlab <- paste("Time Relative to Exiting the Treatment") - } + } } else if (xlab == "") { xlab <- NULL } @@ -1996,7 +2009,7 @@ plot.fect <- function(x, max.pre.periods <- x$time[which(x$count >= max.count.test * proportion & x$time <= 0)] pre.periods <- intersect(pre.periods[1]:pre.periods[length(pre.periods)], max.pre.periods) } - + if(length(pre.periods) != length(x$pre.periods)){ change.pre.periods <- 1 } @@ -2026,7 +2039,7 @@ plot.fect <- function(x, } att.sub <- as.matrix(est.att[show, c("CI.lower.90", "CI.upper.90")]) minBound <- max(abs(att.sub[time0, c("CI.lower.90", "CI.upper.90")]), na.rm = TRUE) - } + } else { if (sum(time[show] > 0) == 0) { message("No non-treatment periods are to be plotted.\n") @@ -2048,20 +2061,20 @@ plot.fect <- function(x, } else { bound.time <- bound.time[which(bound.time >= 1)] } - + ## add legend for 95\% CI set.limits <- "ci" if (is.null(legend.labs)==TRUE) { if (plot.ci == "90") { - set.labels <- "Residual Average (w/ 90% CI)" - } + set.labels <- "Residual Average (w/ 90% CI)" + } else if(plot.ci == "95") { - set.labels <- "ATT (w/ 95% CI)" + set.labels <- "ATT (w/ 95% CI)" } else{ set.labels <- "ATT" - } - } + } + } else { set.labels <- legend.labs } @@ -2088,7 +2101,7 @@ plot.fect <- function(x, set.colors <- c(set.colors, "red") set.linetypes <- c(set.linetypes, "dashed") set.size <- c(set.size, 0.7) - } + } else if (bound.old == "min") { data2 <- cbind.data.frame(c(rep(minbound, each = length(bound.time)))) names(data2) <- "bound" @@ -2130,13 +2143,13 @@ plot.fect <- function(x, } else { CI <- TRUE } - } + } else if (switch.on == FALSE) { if (is.null(x$est.att.off)==TRUE) { CI <- FALSE } else { CI <- TRUE - } + } } if(plot.ci=="none"){ @@ -2144,11 +2157,11 @@ plot.fect <- function(x, } ## data frame for main estimates - if (switch.on == TRUE) { + if (switch.on == TRUE) { ## switch-on effect - if (CI == FALSE) { - data <- cbind.data.frame(time, ATT = x$att, count = count.num)[show,] - } + if (CI == FALSE) { + data <- cbind.data.frame(time, ATT = x$att, count = count.num)[show,] + } else { tb <- est.att data <- cbind.data.frame(time, tb)[show,] @@ -2163,7 +2176,7 @@ plot.fect <- function(x, ci.name <- c("CI.lower.90", "CI.upper.90") } data[,"CI.lower4"] <- data[,"CI.lower3"] <- data[,"CI.lower2"] <- data[,ci.name[1]] - data[,"CI.upper4"] <- data[,"CI.upper3"] <- data[,"CI.upper2"] <- data[,ci.name[2]] + data[,"CI.upper4"] <- data[,"CI.upper3"] <- data[,"CI.upper2"] <- data[,ci.name[2]] pos1 <- intersect(which(data[,"time"] >= (placebo.period[1] + 1)), which(data[,"time"] <= (placebo.period[2] - 1))) pos2 <- c(which(data[,"time"] <= (placebo.period[1] - 1)), which(data[,"time"] >= (placebo.period[2] + 1))) pos3 <- intersect(which(data[,"time"] >= (placebo.period[1])), which(data[,"time"] <= (placebo.period[2] - 1))) @@ -2178,8 +2191,8 @@ plot.fect <- function(x, } else{ ## exit treatment plot - if (CI == FALSE) { - data <- cbind.data.frame(time, ATT = x$att.off, count = count.num)[show,] + if (CI == FALSE) { + data <- cbind.data.frame(time, ATT = x$att.off, count = count.num)[show,] } else { tb <- est.att.off @@ -2197,7 +2210,7 @@ plot.fect <- function(x, } if (is.null(x$est.carry.att)) { data[,"CI.lower4"] <- data[,"CI.lower3"] <- data[,"CI.lower2"] <- data[,ci.name[1]] - data[,"CI.upper4"] <- data[,"CI.upper3"] <- data[,"CI.upper2"] <- data[,ci.name[2]] + data[,"CI.upper4"] <- data[,"CI.upper3"] <- data[,"CI.upper2"] <- data[,ci.name[2]] pos1 <- intersect(which(data[,"time"] >= (carryover.period[1] + 1)), which(data[,"time"] <= (carryover.period[2] - 1))) pos2 <- c(which(data[,"time"] <= (carryover.period[1] - 1)), which(data[,"time"] >= (carryover.period[2] + 1))) pos3 <- intersect(which(data[,"time"] >= (carryover.period[1])), which(data[,"time"] <= (carryover.period[2] - 1))) @@ -2206,15 +2219,15 @@ plot.fect <- function(x, data[pos2, c("ATT2","CI.lower2","CI.upper2")] <- NA data[pos3, c("ATT3","CI.lower3","CI.upper3")] <- NA data[pos4, c("ATT4","CI.lower4","CI.upper4")] <- NA - } + } else { data[,"CI.lower6"] <- data[,"CI.lower5"] <- data[,"CI.lower4"] <- data[,"CI.lower3"] <- data[,"CI.lower2"] <- data[,ci.name[1]] - data[,"CI.upper6"] <- data[,"CI.upper5"] <- data[,"CI.upper4"] <- data[,"CI.upper3"] <- data[,"CI.upper2"] <- data[,ci.name[2]] - + data[,"CI.upper6"] <- data[,"CI.upper5"] <- data[,"CI.upper4"] <- data[,"CI.upper3"] <- data[,"CI.upper2"] <- data[,ci.name[2]] + pos1 <- intersect(which(data[,"time"] >= (carryover.period[1])), which(data[,"time"] <= (carryover.period[2]))) pos2 <- c(which(data[,"time"] <= min(-dim(x$est.carry.att)[1] -1 , -2)), which(data[,"time"] >= (carryover.period[2]) + 1)) pos5 <- intersect(which(data[,"time"] >= min(-dim(x$est.carry.att)[1], -1)), which(data[,"time"] <= -1)) - + pos3 <- intersect(which(data[,"time"] >= (carryover.period[1])), which(data[,"time"] <= (carryover.period[2] - 1))) pos4 <- c(which(data[,"time"] <= min(-dim(x$est.carry.att)[1]-1, -3)), which(data[,"time"] >= (carryover.period[2] + 1))) pos6 <- intersect(which(data[,"time"] >= min(-dim(x$est.carry.att)[1] + 1, -1)), which(data[,"time"] <= -1)) @@ -2225,11 +2238,11 @@ plot.fect <- function(x, data[unique(c(pos4, pos6)), c("ATT4","CI.lower4","CI.upper4")] <- NA data[unique(c(pos1, pos2)), c("ATT5","CI.lower5","CI.upper5")] <- NA data[unique(c(pos3, pos4)), c("ATT6","CI.lower6","CI.upper6")] <- NA - + } } } - } + } } @@ -2242,16 +2255,16 @@ plot.fect <- function(x, } else { rect.length <- (max(data[,"ATT"], na.rm = TRUE) - min(data[,"ATT"], na.rm = TRUE))/2 rect.min <- min(data[,"ATT"], na.rm = TRUE) - rect.length - } - } + } + } else { if (length(ylim) != 0) { rect.length <- (ylim[2] - ylim[1]) / 5 rect.min <- ylim[1] } else { rect.length <- (max(data[,"CI.upper"], na.rm = TRUE) - min(data[,"CI.lower"], na.rm = TRUE))/2 - rect.min <- min(data[,"CI.lower"], na.rm = TRUE) - rect.length - } + rect.min <- min(data[,"CI.lower"], na.rm = TRUE) - rect.length + } } ## plotting @@ -2268,23 +2281,23 @@ plot.fect <- function(x, } } - + # plot bound if (bound.old == "none") { - p <- ggplot(data) - } + p <- ggplot(data) + } else { ## with bounds - p <- ggplot(data2) - p <- p + geom_line(aes(time, bound, colour = type, linetype = type, size = type, group = id)) + p <- ggplot(data2) + p <- p + geom_line(aes(time, bound, colour = type, linetype = type, size = type, group = id)) ## legends for bounds if (is.null(legend.nrow) == TRUE) { - legend.nrow <- ifelse(length(set.limits) <= 3, 1, 2) - } + legend.nrow <- ifelse(length(set.limits) <= 3, 1, 2) + } p <- p + scale_colour_manual(limits = set.limits, labels = set.labels, values =set.colors) + - scale_size_manual(limits = set.limits, labels = set.labels, values = set.size) + + scale_size_manual(limits = set.limits, labels = set.labels, values = set.size) + scale_linetype_manual(limits = set.limits, labels = set.labels, values = set.linetypes) + guides(linetype = guide_legend(title=NULL, nrow=legend.nrow), colour = guide_legend(title=NULL, nrow=legend.nrow), - size = guide_legend(title=NULL, nrow=legend.nrow)) + size = guide_legend(title=NULL, nrow=legend.nrow)) if (effect.bound.ratio == TRUE) { if (is.null(stats.pos)) { @@ -2292,19 +2305,19 @@ plot.fect <- function(x, stats.pos[2] <- ifelse(is.null(ylim), max(data[,"CI.upper"], na.rm = 1), ylim[1]) } p.label <- paste("ATT / Min. Range = ", sprintf("%.3f",x$att.avg / minBound), sep="") - p <- p + annotate("text", x = stats.pos[1], y = stats.pos[2], - label = p.label, size = cex.text, hjust = 0) + p <- p + annotate("text", x = stats.pos[1], y = stats.pos[2], + label = p.label, size = cex.text, hjust = 0) } - } + } - ## xlab and ylab - p <- p + xlab(xlab) + ylab(ylab) + ## xlab and ylab + p <- p + xlab(xlab) + ylab(ylab) ## theme if (theme.bw == TRUE) { - p <- p + theme_bw() + p <- p + theme_bw() } ## grid @@ -2319,34 +2332,34 @@ plot.fect <- function(x, if (plot.ci == "both") { lwidth <- lwidth * 0.5 } - + if (length(xlim)!=0) { if ((xlim[2]>=1 & switch.on == TRUE) | (xlim[1]<=0 & switch.on == FALSE)) { if(start0 == FALSE){ - if(plot.ci == 'both'){ + if(plot.ci == 'both'){ p <- p + geom_vline(xintercept = 0.5, colour=lcolor,size = lwidth) } - else{ - p <- p + geom_vline(xintercept = 0, colour=lcolor,size = lwidth) + else{ + p <- p + geom_vline(xintercept = 0, colour=lcolor,size = lwidth) } } else{ - if(plot.ci == 'both'){ + if(plot.ci == 'both'){ p <- p + geom_vline(xintercept = -0.5, colour=lcolor,size = lwidth) } else{ - p <- p + geom_vline(xintercept = -1, colour=lcolor,size = lwidth) + p <- p + geom_vline(xintercept = -1, colour=lcolor,size = lwidth) } } } - } + } else { if(start0 == FALSE){ if(plot.ci == 'both'){ p <- p + geom_vline(xintercept = 0.5, colour=lcolor,size = lwidth) } else{ - p <- p + geom_vline(xintercept = 0, colour=lcolor,size = lwidth) + p <- p + geom_vline(xintercept = 0, colour=lcolor,size = lwidth) } } else{ @@ -2354,11 +2367,11 @@ plot.fect <- function(x, p <- p + geom_vline(xintercept = -0.5, colour=lcolor,size = lwidth) } else{ - p <- p + geom_vline(xintercept = -1, colour=lcolor,size = lwidth) + p <- p + geom_vline(xintercept = -1, colour=lcolor,size = lwidth) } } - } - + } + ## legend and axes @@ -2374,7 +2387,7 @@ plot.fect <- function(x, plot.title = element_text(size = cex.main, hjust = 0.5, face="bold", margin = margin(10, 0, 10, 0))) ## add ATT point estimates - classic <- 0 + classic <- 0 if(highlight==FALSE){ classic <- 1 } @@ -2400,13 +2413,13 @@ plot.fect <- function(x, ## CIs if (CI == TRUE) { if (plot.ci == "95") { - p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower, ymax=CI.upper),alpha=0.2) - } + p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower, ymax=CI.upper),alpha=0.2) + } else { - p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower.90, ymax=CI.upper.90),alpha=0.2) - } + p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower.90, ymax=CI.upper.90),alpha=0.2) + } } - } + } else if(plot.ci == 'both') { if(CI==TRUE){ if(plot.ci.point %in% c("both","95")){ @@ -2414,14 +2427,14 @@ plot.fect <- function(x, } if(plot.ci.point %in% c("both","90")){ p <- p + geom_pointrange(data = data, aes(x = time, y = ATT, ymin=CI.lower.90, ymax=CI.upper.90), lwd=0.6,fatten = 2) - } + } } else{ - p <- p + geom_point(data = data, aes(x = time, y = ATT), size=1.2) + p <- p + geom_point(data = data, aes(x = time, y = ATT), size=1.2) } } - } + } else if(classic==0 && switch.on==TRUE) { ## point estimates ## placebo tests @@ -2440,7 +2453,7 @@ plot.fect <- function(x, ## CIs p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower3, ymax=CI.upper3),alpha=0.2, na.rm = FALSE) p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower4, ymax=CI.upper4),alpha=0.2, fill = "#0000FF", na.rm = FALSE) - } + } else if(plot.ci == "both") { pos.ci <- intersect(which(data[,"time"] >= (placebo.period[1])), which(data[,"time"] <= (placebo.period[length(placebo.period)]))) pos.ci2 <- setdiff(1:dim(data)[1], pos.ci) @@ -2452,11 +2465,11 @@ plot.fect <- function(x, if(plot.ci.point %in% c("both","90")){ p <- p + geom_pointrange(data = data[pos.ci,], aes(x = time, y = ATT, ymin=CI.lower.90, ymax=CI.upper.90), lwd=0.6, color="blue", fill="blue",fatten = 2) p <- p + geom_pointrange(data = data[pos.ci2,], aes(x = time, y = ATT, ymin=CI.lower.90, ymax=CI.upper.90), lwd=0.6,fatten = 2) - } + } } else{ p <- p + geom_point(data = data[pos.ci,], aes(x = time, y = ATT), lwd=0.6, color="blue", fill="blue",size=1.2) - p <- p + geom_point(data = data[pos.ci2,], aes(x = time, y = ATT), lwd=0.6,size=1.2) + p <- p + geom_point(data = data[pos.ci2,], aes(x = time, y = ATT), lwd=0.6,size=1.2) } } } @@ -2480,7 +2493,7 @@ plot.fect <- function(x, ## CIs p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower3, ymax=CI.upper3),alpha=0.2,na.rm = FALSE) p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower4, ymax=CI.upper4),alpha=0.2, fill = "pink",na.rm = FALSE) - } + } else { data[,'time'] <- length(x$carry.att) + data[,'time'] if(vis == "none"){ @@ -2502,8 +2515,8 @@ plot.fect <- function(x, p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower4, ymax=CI.upper4),alpha=0.2, fill = "pink",na.rm = FALSE) p <- p + geom_ribbon(data = data, aes(x = time, ymin=CI.lower6, ymax=CI.upper6),alpha=0.2, fill = "blue",na.rm = FALSE) } - } - } + } + } else if(plot.ci == "both") { if (is.null(x$est.carry.att)) { pos.ci <- intersect(which(data[,"time"] >= (carryover.period[1])), which(data[,"time"] <= (carryover.period[length(carryover.period)]))) @@ -2520,8 +2533,8 @@ plot.fect <- function(x, } else{ p <- p + geom_point(data = data[pos.ci,], aes(x = time, y = ATT), lwd=0.6, color="red", fill="red",size=1.2) - p <- p + geom_point(data = data[pos.ci2,], aes(x = time, y = ATT), lwd=0.6,size=1.2) - } + p <- p + geom_point(data = data[pos.ci2,], aes(x = time, y = ATT), lwd=0.6,size=1.2) + } } else{ T.carry <- -dim(x$est.carry.att)[1] + 1 @@ -2544,9 +2557,9 @@ plot.fect <- function(x, else{ p <- p + geom_point(data = data[pos.ci,], aes(x = time, y = ATT), lwd=0.6, color="red", fill="red",size=1.2) p <- p + geom_point(data = data[pos.ci2,], aes(x = time, y = ATT), lwd=0.6, color="blue", fill="red",size=1.2) - p <- p + geom_point(data = data[pos.ci3,], aes(x = time, y = ATT), lwd=0.6, size=1.2) + p <- p + geom_point(data = data[pos.ci3,], aes(x = time, y = ATT), lwd=0.6, size=1.2) } - + } } @@ -2562,18 +2575,18 @@ plot.fect <- function(x, else{ loo.equiv <- 0 } - - if (type %in% c('equiv','gap') && loo.equiv == 0) { + + if (type %in% c('equiv','gap') && loo.equiv == 0) { for (i in 1:length(stats)) { if ("F.p" %in% stats[i]) { if (change.proportion | change.pre.periods | !is.null(show.group) | use.balance) { x$loo <- FALSE - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, f.threshold = f.threshold) f.p <- test.out$f.p - } + } else { f.p <- x$test.out$f.p } @@ -2584,12 +2597,12 @@ plot.fect <- function(x, if ("F.stat" %in% stats[i]) { if (change.proportion | change.pre.periods | !is.null(show.group) | use.balance) { x$loo <- FALSE - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, f.threshold = f.threshold) f.stat <- test.out$f.stat - } + } else { f.stat <- x$test.out$f.stat } @@ -2602,12 +2615,12 @@ plot.fect <- function(x, if (change.f.threshold | change.proportion | change.pre.periods | !is.null(show.group)|use.balance) { x$loo <- FALSE # some problems here, should change to change.f.threshold; change.proportion; change.pre.periods - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, f.threshold = f.threshold) f.equiv.p <- test.out$f.equiv.p - } + } else { f.equiv.p <- x$test.out$f.equiv.p } @@ -2619,12 +2632,12 @@ plot.fect <- function(x, # calculate new p value (ziyi: re-add this) if (change.tost.threshold | change.proportion | change.pre.periods | !is.null(show.group)|use.balance) { x$loo <- FALSE - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, tost.threshold = tost.threshold) tost.equiv.p <- test.out$tost.equiv.p - } + } else { tost.equiv.p <- x$test.out$tost.equiv.p } @@ -2634,12 +2647,12 @@ plot.fect <- function(x, } if ("placebo.p" %in% stats[i]) { if (change.tost.threshold | change.proportion | change.pre.periods | !is.null(show.group)) { - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, tost.threshold = tost.threshold) placebo.p <- test.out$placebo.p - } + } else { placebo.p <- x$test.out$placebo.p } @@ -2653,25 +2666,25 @@ plot.fect <- function(x, if (change.tost.threshold | change.proportion | change.pre.periods | !is.null(show.group)) { test.out <- diagtest(x, proportion = proportion, pre.periods = pre.periods, tost.threshold = tost.threshold) placebo.equiv.p <- test.out$placebo.equiv.p - } + } else { placebo.equiv.p <- x$test.out$placebo.equiv.p } p.label1 <- paste0(stats.labs[i],": ", sprintf("%.3f", placebo.equiv.p)) p.label <- paste0(p.label, p.label1, "\n") - } - } + } + } } else if(type %in% c('equiv','gap') && loo.equiv == 1){ #loo for (i in 1:length(stats)) { if ("F.p" %in% stats[i]) { if (change.proportion | change.pre.periods | !is.null(show.group)) { - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, f.threshold = f.threshold) f.p <- test.out$f.p - } + } else { f.p <- x$test.out$f.p } @@ -2681,12 +2694,12 @@ plot.fect <- function(x, } if ("F.stat" %in% stats[i]) { if (change.proportion | change.pre.periods | !is.null(show.group)) { - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, f.threshold = f.threshold) f.stat <- test.out$f.stat - } + } else { f.stat <- x$test.out$f.stat } @@ -2697,12 +2710,12 @@ plot.fect <- function(x, if ("F.equiv.p" %in% stats[i]) { # calculate new p value (ziyi: re-add this) if (change.f.threshold | change.proportion | change.pre.periods | !is.null(show.group)) { - loo.test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + loo.test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, f.threshold = f.threshold) f.equiv.p <- loo.test.out$f.equiv.p - } + } else { f.equiv.p <- x$loo.test.out$f.equiv.p } @@ -2713,12 +2726,12 @@ plot.fect <- function(x, if ("equiv.p" %in% stats[i]) { # calculate new p value (ziyi: re-add this) if (change.tost.threshold | change.proportion | change.pre.periods | !is.null(show.group)) { - loo.test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + loo.test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, tost.threshold = tost.threshold) tost.equiv.p <- loo.test.out$tost.equiv.p - } + } else { tost.equiv.p <- x$loo.test.out$tost.equiv.p } @@ -2727,18 +2740,18 @@ plot.fect <- function(x, p.label <- paste0(p.label, p.label1, "\n") } } - } - else if(type=='gap' && placeboTest==TRUE){ + } + else if(type=='gap' && placeboTest==TRUE){ ## stats for (i in 1:length(stats)) { if ("placebo.p" %in% stats[i]) { if (change.tost.threshold | change.proportion | change.pre.periods | !is.null(show.group)) { - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, tost.threshold = tost.threshold) placebo.p <- test.out$placebo.p - } + } else { placebo.p <- x$test.out$placebo.p } @@ -2752,26 +2765,26 @@ plot.fect <- function(x, if (change.tost.threshold | change.proportion | change.pre.periods | !is.null(show.group)) { test.out <- diagtest(x, proportion = proportion, pre.periods = pre.periods, tost.threshold = tost.threshold) placebo.equiv.p <- test.out$placebo.equiv.p - } + } else { placebo.equiv.p <- x$test.out$placebo.equiv.p } p.label1 <- paste0(stats.labs[i],": ", sprintf("%.3f", placebo.equiv.p)) p.label <- paste0(p.label, p.label1, "\n") - } - } + } + } } else if(type=='exit' && carryoverTest==TRUE){ ## stats for (i in 1:length(stats)) { if ("carryover.p" %in% stats[i]) { if (change.tost.threshold | change.proportion | change.pre.periods | !is.null(show.group)) { - test.out <- diagtest(x, - proportion = proportion, - pre.periods = pre.periods, + test.out <- diagtest(x, + proportion = proportion, + pre.periods = pre.periods, tost.threshold = tost.threshold) carryover.p <- test.out$carryover.p - } + } else { carryover.p <- x$test.out$carryover.p } @@ -2785,16 +2798,16 @@ plot.fect <- function(x, if (change.tost.threshold | change.proportion | change.pre.periods| !is.null(show.group)) { test.out <- diagtest(x, proportion = proportion, pre.periods = pre.periods, tost.threshold = tost.threshold) carryover.equiv.p <- test.out$carryover.equiv.p - } + } else { carryover.equiv.p <- x$test.out$carryover.equiv.p } p.label1 <- paste0(stats.labs[i],": ", sprintf("%.3f", carryover.equiv.p)) p.label <- paste0(p.label, p.label1, "\n") - } - } + } + } } - + @@ -2802,21 +2815,21 @@ plot.fect <- function(x, ##hpos <- ifelse(switch.on == TRUE, 0, 1) hpos <- 0 if ("none" %in% stats == FALSE) { - if (is.null(stats.pos)) { + if (is.null(stats.pos)) { if (switch.on == TRUE) { stats.pos[1] <- min(data[,"time"], na.rm = 1) - } + } else { stats.pos[1] <- min(data[,"time"], na.rm = 1) } ci.top <- max(data[,"CI.upper"], na.rm = 1) - stats.pos[2] <- ifelse(is.null(ylim), ci.top, ylim[2]) + stats.pos[2] <- ifelse(is.null(ylim), ci.top, ylim[2]) } if (!is.null(p.label)) { - p <- p + annotate("text", x = stats.pos[1], y = stats.pos[2], + p <- p + annotate("text", x = stats.pos[1], y = stats.pos[2], label = p.label, size = cex.text, hjust = hpos, vjust = "top") - } - } + } + } ## histogram if (count == TRUE) { @@ -2825,11 +2838,11 @@ plot.fect <- function(x, data[,"ymin"] <- rep(rect.min, dim(data)[1]) data[,"ymax"] <- rect.min + (data[,"count"]/max.count) * 0.8 * rect.length xx <- range(data$time) - p <- p + geom_rect(data = data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), + p <- p + geom_rect(data = data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), fill = "grey70", colour = "grey69", alpha = 0.4, size = 0.2) - p <- p + annotate("text", x = max.count.pos - 0.02 * (xx[2]-xx[1]), - y = max(data$ymax) + 0.2 * rect.length, - label = max.count, size = cex.text * 0.8, hjust = 0.5) + p <- p + annotate("text", x = max.count.pos - 0.02 * (xx[2]-xx[1]), + y = max(data$ymax) + 0.2 * rect.length, + label = max.count, size = cex.text * 0.8, hjust = 0.5) } T.post.length <- length(data[which(data[,'time']>0),'time']) @@ -2841,7 +2854,7 @@ plot.fect <- function(x, p <- p + scale_x_continuous(breaks=c(data[,'time'])) } - + ## title if (is.null(main) == TRUE) { p <- p + ggtitle(maintext) @@ -2856,7 +2869,7 @@ plot.fect <- function(x, ##xlim - + } if(type == "calendar"){ @@ -2864,7 +2877,7 @@ plot.fect <- function(x, CI <- NULL if (is.null(x$est.eff.calendar)==TRUE) { CI <- FALSE - } + } else { CI <- TRUE } @@ -2873,15 +2886,15 @@ plot.fect <- function(x, } ## axes labels if (is.null(xlab) == TRUE) { - xlab <- "Calendar Time" - } + xlab <- "Calendar Time" + } else if (xlab == "") { xlab <- NULL } if (is.null(ylab) == TRUE) { ylab <- ytitle - } + } else if (ylab == "") { ylab <- NULL } @@ -2915,7 +2928,7 @@ plot.fect <- function(x, d2 <- data.2 <- t(d2) rownames(d2) <- rownames(data.2) <- rownames(x$eff.calendar.fit)[which(!is.na(x$est.eff.calendar.fit[,1]))] } - } + } else { if(is.null(x$est.eff.calendar)){ stop("Uncertainty estimates not available.\n") @@ -2930,22 +2943,22 @@ plot.fect <- function(x, d2 <- data.2 <- t(d2) rownames(d2) <- rownames(data.2) <- rownames(x$est.eff.calendar.fit)[which(!is.na(x$est.eff.calendar.fit[,1]))] } - + if (length(ylim) != 0) { rect.length <- (ylim[2] - ylim[1]) / 5 rect.min <- ylim[1] } else { rect.length <- (max(c(data.1[,4],data.2[,4]), na.rm = TRUE) - min(c(data.1[,3],data.2[,3]), na.rm = TRUE))/2 - rect.min <- min(c(data.1[,3],data.2[,3]), na.rm = TRUE) - rect.length - } + rect.min <- min(c(data.1[,3],data.2[,3]), na.rm = TRUE) - rect.length + } } p <- ggplot() - ## xlab and ylab + ## xlab and ylab p <- p + xlab(xlab) + ylab(ylab) ## theme if (theme.bw == TRUE) { - p <- p + theme_bw() + p <- p + theme_bw() } ## grid @@ -2987,9 +3000,9 @@ plot.fect <- function(x, ymax=ymax) max.count.pos <- mean(TTT[which.max(d1[,'count'])]) p <- p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplot,fill='gray50',alpha=0.3,size=0.3,color='black') - p <- p + annotate("text", x = max.count.pos - 0.02 * T.gap, - y = max(data.toplot$ymax) + 0.2 * rect.length, - label = max(x$N.calendar), size = cex.text * 0.8, hjust = 0.5) + p <- p + annotate("text", x = max.count.pos - 0.02 * T.gap, + y = max(data.toplot$ymax) + 0.2 * rect.length, + label = max(x$N.calendar), size = cex.text * 0.8, hjust = 0.5) } ## title @@ -3021,7 +3034,7 @@ plot.fect <- function(x, # break # } # } - # } + # } # } ## xlim if (is.null(xlim) == FALSE) { @@ -3043,6 +3056,377 @@ plot.fect <- function(x, } + if(type == "hte"){ + CI <- NULL #decide if we need plot uncertainties + if ("est.avg.HTE" %in% names(x)){ + CI <- TRUE + } + if (is.null(CI)) { + CI <- FALSE + } + if(plot.ci=="none"){ + CI <- FALSE + } + ## axes labels + if (is.null(xlab) == TRUE) { + xlab <- "Moderator" + } + else if (xlab == "") { + xlab <- NULL + } + + if (is.null(ylab) == TRUE) { + ylab <- ytitle + } + else if (ylab == "") { + ylab <- NULL + } + + ## y=0 line type + lcolor <- "white" + lwidth <- 2 + if (theme.bw == TRUE) { + lcolor <- "#AAAAAA70" + lwidth <- 1.5 + } + + if (CI == FALSE) { + message("Uncertainty estimates not available.\n") + YVAR = rep(NA,length(x$avg.HTE)) + XVAR = rep(NA,length(x$avg.HTE)) + for (i in 1:length(x$avg.HTE)){ + YVAR[i] = x$avg.HTE[i] + XVAR[i] = x$Val.HTE[i] + } + d1 <- cbind.data.frame(YVAR,XVAR) + + if (moderator.loess == TRUE){ + YVAR.fit = rep(NA,length(x$avg.HTE.fit)) + XVAR.fit = rep(NA,length(x$avg.HTE.fit)) + for (i in 1:length(x$avg.HTE.fit)){ + YVAR.fit[i] = x$avg.HTE.fit[i] + XVAR.fit[i] = x$Val.HTE.fit[i] + } + d2 <- cbind.data.frame(YVAR.fit,XVAR.fit) + } + + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YVAR), na.rm = TRUE) - min(c(YVAR), na.rm = TRUE))/2 + rect.min <- min(c(YVAR), na.rm = TRUE) - rect.length + } + } + else { + YVAR = rep(NA,length(x$avg.HTE)) + XVAR = rep(NA,length(x$avg.HTE)) + YMIN = rep(NA,length(x$avg.HTE)) + YMAX = rep(NA,length(x$avg.HTE)) + for (i in 1:length(x$avg.HTE)){ + YVAR[i] = x$est.avg.HTE[i,1] + YMIN[i] = x$est.avg.HTE[i,3] + YMAX[i] = x$est.avg.HTE[i,4] + XVAR[i] = x$Val.HTE[i] + } + d1 <- cbind.data.frame(YVAR,YMIN,YMAX,XVAR) + + if (moderator.loess == TRUE){ + YVAR.fit = rep(NA,length(x$avg.HTE.fit)) + XVAR.fit = rep(NA,length(x$avg.HTE.fit)) + YMIN.fit = rep(NA,length(x$avg.HTE.fit)) + YMAX.fit = rep(NA,length(x$avg.HTE.fit)) + for (i in 1:length(x$avg.HTE.fit)){ + YVAR.fit[i] = x$est.avg.HTE.fit[i,1] + YMIN.fit[i] = x$est.avg.HTE.fit[i,3] + YMAX.fit[i] = x$est.avg.HTE.fit[i,4] + XVAR.fit[i] = x$Val.HTE[i] + } + d2 <- cbind.data.frame(YVAR.fit,YMIN.fit,YMAX.fit,XVAR.fit) + } + + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YMAX), na.rm = TRUE) - min(c(YMIN), na.rm = TRUE))/2 + rect.min <- min(c(YMIN), na.rm = TRUE) - rect.length + } + } + + + p <- ggplot() + ## xlab and ylab + p <- p + xlab(xlab) + ylab(ylab) + if(x$moderator.type == "continuous"){ + x_labels = rep("",length(XVAR)) + for(i in 1:length(XVAR)){ + if (i == 1){ + x_labels[i] = paste("0%-",round(100*XVAR[i],1),"%") + } + else{ + x_labels[i] = paste(round(100*XVAR[i-1],1),"%-",round(100*XVAR[i],1),"%") + } + + } + p <- p + scale_x_continuous(breaks = XVAR, labels = x_labels) + } + ## theme + if (theme.bw == TRUE) { + p <- p + theme_bw() + } + + ## grid + if (gridOff == TRUE) { + p <- p + theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + } + + # horizontal 0 line + #p <- p + geom_hline(yintercept = 0, colour = lcolor,size = lwidth) + + + if(CI==FALSE){ + #p <- p + geom_point(aes(x=XVAR,y=YVAR,color='gray50',fill='gray50',alpha=1,size=1.2)) + p <- p + geom_point(aes(x=d1[,2],y=d1[,1]),color='gray50',fill='gray50',alpha=1) + if (moderator.loess == TRUE){ + p <- p + geom_line(aes(x=d2[,2],y=d2[,1]),color='skyblue',size=1.1) + } + } else { + #p <- p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX,color='gray50',fill='gray50',alpha=1,size=0.6)) + p <- p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX),color='gray50',fill='gray50',alpha=1) + if (moderator.loess == TRUE){ + p <- p + geom_line(aes(x=d2[,4],y=d2[,1]),color='skyblue',size=1.1) + p <- p + geom_ribbon(aes(x=d2[,4],ymin=d2[,2],ymax=d2[,3]),color='skyblue',fill='skyblue',alpha=0.5,size=0) + } + } + if(count==TRUE){ + NcoCOUNT = rep(NA,length(x$avg.HTE)) + NtrCOUNT = rep(NA,length(x$avg.HTE)) + NCOUNT = rep(NA,length(x$avg.HTE)) + for (i in 1:length(x$avg.HTE)){ + # NtrCOUNT[i] = x[[i]]$NtrHTE + # NcoCOUNT[i] = x[[i]]$NHTE - NtrCOUNT[i] + NCOUNT[i] = x$N.HTE[i] + NtrCOUNT[i] = x$Ntr.HTE[i] + NcoCOUNT[i] = NCOUNT[i] - NtrCOUNT[i] + } + T.start <- c() + T.end <- c() + ymin <- c() + ymaxco <- c() + ymaxtr <- c() + T.gap <- (max(XVAR)-min(XVAR))/length(XVAR) + for(i in c(1:length(XVAR))){ + T.start <- c(T.start,XVAR[i]-0.25*T.gap) + T.end <- c(T.end,XVAR[i]+0.25*T.gap) + ymin <- c(ymin, rect.min) + ymaxco <- c(ymaxco, rect.min+rect.length*NcoCOUNT[i]/max(NCOUNT)) + ymaxtr <- c(ymaxtr, rect.min+rect.length*NCOUNT[i]/max(NCOUNT)) + } + data.toplotco <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymin, + ymax=ymaxco) + data.toplottr <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymaxco, + ymax=ymaxtr) + max.count.pos <- mean(XVAR[which.max(NCOUNT)]) + p <- p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplotco,fill='gray50',alpha=0.3,size=0.3,color='black') + p <- p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplottr,fill='red',alpha=0.3,size=0.3,color='black') + p <- p + annotate("text", x = max.count.pos - 0.02 * T.gap, + y = max(data.toplottr$ymax) + 0.2 * rect.length, + label = max(NCOUNT), size = cex.text * 0.8, hjust = 0.5) + } + if (is.null(main) == TRUE) { + p <- p + ggtitle(maintext) + theme(plot.title = element_text(hjust = 0.5)) + } else if (main!=""){ + p <- p + ggtitle(main) + } + + # if (is.null(save_path) == FALSE){ + # filename <- file.path(save_path, paste0("plot_avg.png")) + # ggsave(filename,p) + # } + } + + if(type == 'gap.sub'){ + CI <- NULL #decide if we need plot uncertainties + if ("est.att.HTE" %in% names(x)){ + if(! is.null(x$est.att.HTE)){ + CI <- TRUE + } + } + if (is.null(CI)) { + CI <- FALSE + } + if(plot.ci=="none"){ + CI <- FALSE + } + + #decide which value of moderator to display + moderator.value = x$Val.HTE + if (is.null(moderator)){ + cat("Please choose and assign a value to moderator from the following list:\n") + print(moderator.value) + stop("The program has been stopped because moderator is NULL.") + } + else{ + if (! moderator %in% moderator.value){ + cat("Please choose and assign a value to moderator from the following list:\n") + print(moderator.value) + stop("The program has been stopped because of wrong value of moderator.") + } + } + + MODid = which(moderator.value == moderator) + + ## axes labels + if (is.null(xlab) == TRUE) { + xlab <- "Relative Time" + } + else if (xlab == "") { + xlab <- NULL + } + + if (is.null(ylab) == TRUE) { + ylab <- ytitle + } + else if (ylab == "") { + ylab <- NULL + } + + ## y=0 line type + lcolor <- "white" + lwidth <- 2 + if (theme.bw == TRUE) { + lcolor <- "#AAAAAA70" + lwidth <- 1.5 + } + + if (CI == FALSE) { + message("Uncertainty estimates not available.\n") + temp.att <- x$att.HTE[[MODid]] + temp.time <- x$time.HTE[[MODid]] + temp.count <- x$count.HTE[[MODid]] + YVAR = rep(NA,length(temp.att)) + XVAR = rep(NA,length(temp.time)) + NCOUNT = rep(NA,length(temp.count)) + for (j in 1:length(temp.att)){ + YVAR[j] = temp.att[j] + XVAR[j] = temp.time[j] + NCOUNT[j] = temp.count[j] + } + data.toplot.main <- cbind.data.frame(YVAR,XVAR) + + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YVAR), na.rm = TRUE) - min(c(YVAR), na.rm = TRUE))/2 + rect.min <- min(c(YVAR), na.rm = TRUE) - rect.length + } + } + else { + temp.est.att = x$est.att.HTE[[MODid]] + temp.time <- x$time.HTE[[MODid]] + rm.pos <- which(is.na(temp.est.att[,3])) + if (length(rm.pos) != 0){ + temp.est.att <- temp.est.att[-rm.pos,] + temp.time <- x$time.HTE[[MODid]][-rm.pos] + } + YVAR = rep(NA,dim(temp.est.att)[1]) + XVAR = rep(NA,dim(temp.est.att)[1]) + YMIN = rep(NA,dim(temp.est.att)[1]) + YMAX = rep(NA,dim(temp.est.att)[1]) + NCOUNT = rep(NA,dim(temp.est.att)[1]) + for (j in 1:dim(temp.est.att)[1]){ + YVAR[j] = temp.est.att[j,1] + YMIN[j] = temp.est.att[j,3] + YMAX[j] = temp.est.att[j,4] + XVAR[j] = temp.time[j] + NCOUNT[j] = temp.est.att[j,6] + } + data.toplot.main <- cbind.data.frame(YVAR,YMIN,YMAX,XVAR) + if (length(ylim) != 0) { + rect.length <- (ylim[2] - ylim[1]) / 5 + rect.min <- ylim[1] + } else { + rect.length <- (max(c(YMAX), na.rm = TRUE) - min(c(YMIN), na.rm = TRUE))/2 + rect.min <- min(c(YMIN), na.rm = TRUE) - rect.length + } + } + + temp.p <- ggplot(data.toplot.main) + ## xlab and ylab + temp.p <- temp.p + xlab(xlab) + ylab(ylab) + + ## theme + if (theme.bw == TRUE) { + temp.p <- temp.p + theme_bw() + } + + ## grid + if (gridOff == TRUE) { + temp.p <- temp.p + theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()) + } + + # horizontal 0 line + #temp.p <- temp.p + geom_hline(yintercetemp.pt = 0, colour = lcolor,size = lwidth) + + + if(CI==FALSE){ + #temp.p <- temp.p + geom_point(aes(x=XVAR,y=YVAR,color='gray50',fill='gray50',alpha=1,size=1.2)) + temp.p <- temp.p + geom_point(aes(x=XVAR,y=YVAR),color='gray50',fill='gray50',alpha=1) + } else { + #temp.p <- temp.p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX,color='gray50',fill='gray50',alpha=1,size=0.6)) + temp.p <- temp.p + geom_pointrange(aes(x=XVAR,y=YVAR,ymin=YMIN,ymax=YMAX),color='gray50',fill='gray50',alpha=1) + } + if(count==TRUE){ + + T.start <- c() + T.end <- c() + ymin <- c() + ymax <- c() + T.gap <- (max(XVAR)-min(XVAR))/length(XVAR) + for(j in c(1:length(XVAR))){ + T.start <- c(T.start,XVAR[j]-0.25*T.gap) + T.end <- c(T.end,XVAR[j]+0.25*T.gap) + ymin <- c(ymin, rect.min) + ymax <- c(ymax, rect.min+rect.length*NCOUNT[j]/max(NCOUNT)) + } + data.toplot <- cbind.data.frame(xmin=T.start, + xmax=T.end, + ymin=ymin, + ymax=ymax) + max.count.pos <- mean(XVAR[which.max(NCOUNT)]) + temp.p <- temp.p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplot,fill='gray50',alpha=0.3,size=0.3,color='black') + temp.p <- temp.p + annotate("text", x = max.count.pos - 0.02 * T.gap, + y = max(data.toplot$ymax) + 0.2 * rect.length, + label = max(NCOUNT), size = cex.text * 0.8, hjust = 0.5) + } + + if(moderator.loess == TRUE) { + + } + ## title + if (is.null(main) == TRUE) { + temp.title = paste0("Dynamic Effect when Moderator = ",x$Val.HTE[MODid]) + temp.p <- temp.p + ggtitle(temp.title) + theme(plot.title = element_text(hjust = 0.5)) + } else if (main!=""){ + temp.p <- temp.p + ggtitle(main) + } + + # if (is.null(save_path) == FALSE){ + # filename <- file.path(save_path, paste0("plot_dynamic_",i,".png")) + # ggsave(filename,temp.p) + # } + + p <- temp.p + } + + + if(type == "box"){ if (is.null(xlab)==TRUE) { xlab <- index[2] @@ -3069,18 +3453,18 @@ plot.fect <- function(x, } p <- ggplot() - ## xlab and ylab - p <- p + xlab(xlab) + ylab(ylab) + ## xlab and ylab + p <- p + xlab(xlab) + ylab(ylab) ## theme if (theme.bw == TRUE) { - p <- p + theme_bw() + p <- p + theme_bw() } ## title if (!is.null(main)) { p <- p + ggtitle(main) - } + } ## grid @@ -3110,7 +3494,7 @@ plot.fect <- function(x, data.count <- data.count[which(data.count[,'time']>=min(xlim) & data.count[,'time']<=max(xlim)),] data.toplot <- data.toplot[which(data.toplot[,'time']>=min(xlim) & data.toplot[,'time']<=max(xlim)),] } - + data.use <- merge(data.toplot,data.count,by = "time") #print(data.use) @@ -3118,7 +3502,7 @@ plot.fect <- function(x, if (length(ylim) != 0) { rect.length <- (ylim[2] - ylim[1]) / 5 rect.min <- ylim[1] - } + } else { rect.length <- (max(data.use[,'eff'], na.rm = TRUE) - min(data.use[,'eff'], na.rm = TRUE))/3 rect.min <- min(data.use[,'eff'], na.rm = TRUE) - rect.length @@ -3148,12 +3532,12 @@ plot.fect <- function(x, data.post.1$time <- factor(data.post.1$time,levels=levels) data.post.2$time <- factor(data.post.2$time,levels=levels) - p <- p + geom_boxplot(aes(x=time,y=eff),position="dodge", alpha=0.5, + p <- p + geom_boxplot(aes(x=time,y=eff),position="dodge", alpha=0.5, data = data.pre.1,fill='skyblue', outlier.fill='skyblue',outlier.size = 1.25, outlier.color='skyblue', outlier.alpha = 0.5) - p <- p + geom_boxplot(aes(x=time,y=eff),position="dodge", alpha=0.5, + p <- p + geom_boxplot(aes(x=time,y=eff),position="dodge", alpha=0.5, data = data.post.1,fill='pink',outlier.fill = 'pink', outlier.size = 1.25,outlier.color = 'pink', outlier.alpha = 0.5) @@ -3163,7 +3547,7 @@ plot.fect <- function(x, p <- p + geom_point(aes(x=time,y=eff),data = data.pre.2, color="skyblue", size=1.25, alpha=0.8) p <- p + scale_x_discrete(limits =levels) - + if(count==TRUE){ T.start <- c() T.end <- c() @@ -3171,8 +3555,8 @@ plot.fect <- function(x, ymax <- c() T.gap <- 1 for(i in c(1:dim(data.count)[1])){ - T.start <- c(T.start,data.count[i,1]-0.25*T.gap- min(data.count[,1]) + 1) - T.end <- c(T.end,data.count[i,1]+0.25*T.gap- min(data.count[,1])+1) + T.start <- c(T.start,data.count[i,1]-0.25*T.gap- min(data.count[,1]) + 1) + T.end <- c(T.end,data.count[i,1]+0.25*T.gap- min(data.count[,1])+1) ymin <- c(ymin, rect.min) ymax <- c(ymax, rect.min+rect.length*data.count[i,2]/max(data.count[,2])) } @@ -3182,9 +3566,9 @@ plot.fect <- function(x, ymax=ymax) max.count.pos <- data.count[which.max(data.count[,2]),1][1]- min(data.count[,1])+1 p <- p + geom_rect(aes(xmin=xmin,xmax=xmax,ymin=ymin,ymax=ymax),data=data.toplot,fill='gray50',alpha=0.3,size=0.3,color='black') - p <- p + annotate("text", x = max.count.pos - 0.02 * T.gap, - y = max(data.toplot$ymax) + 0.1 * rect.length, - label = max(data.count[,2]), size = cex.text * 0.7, hjust = 0.5) + p <- p + annotate("text", x = max.count.pos - 0.02 * T.gap, + y = max(data.toplot$ymax) + 0.1 * rect.length, + label = max(data.count[,2]), size = cex.text * 0.7, hjust = 0.5) } ## ylim @@ -3284,7 +3668,7 @@ plot.fect <- function(x, breaks <- c(breaks,8) label <- c(label,"Balanced Sample: Pre") } - + TT <- dim(m)[1] N <- dim(m)[2] units <- rep(rev(1:N), each = TT) @@ -3308,7 +3692,7 @@ plot.fect <- function(x, if (axis.lab == "both") { if (length(axis.lab.gap)==2) { x.gap <- axis.lab.gap[1] - y.gap <- axis.lab.gap[2] + y.gap <- axis.lab.gap[2] } else { x.gap <- y.gap <- axis.lab.gap[1] } @@ -3323,20 +3707,20 @@ plot.fect <- function(x, N.b <- seq(from = N, to = 1, by = -(y.gap + 1)) } id <- rev(id) - + p <- ggplot(data, aes(x = period, y = units, - fill = res), position = "identity") - + fill = res), position = "identity") + if (gridOff == FALSE) { - p <- p + geom_tile(colour="gray90", size=0.05, stat="identity") + p <- p + geom_tile(colour="gray90", size=0.05, stat="identity") } else { p <- p + geom_tile(stat="identity") } - + p <- p + - labs(x = xlab, y = ylab, + labs(x = xlab, y = ylab, title=main) + - theme_bw() + + theme_bw() + scale_fill_manual(NA, breaks = breaks, values = col, labels=label) #if(4%in%all) { @@ -3371,7 +3755,7 @@ plot.fect <- function(x, } else if (axis.lab == "unit") { p <- p + scale_x_continuous(expand = c(0, 0), breaks = T.b, labels = NULL) + - scale_y_continuous(expand = c(0, 0), breaks = N.b, labels = id[N.b]) + scale_y_continuous(expand = c(0, 0), breaks = N.b, labels = id[N.b]) } else if (axis.lab == "time") { p <- p + scale_x_continuous(expand = c(0, 0), breaks = T.b, labels = time.label[T.b]) + @@ -3381,7 +3765,7 @@ plot.fect <- function(x, p <- p + scale_x_continuous(expand = c(0, 0), breaks = 1:length(show), labels = NULL) + scale_y_continuous(expand = c(0, 0), breaks = 1:N, labels = NULL) } - + if(length(all)>=3) { p <- p + guides(fill=guide_legend(nrow=2,byrow=TRUE)) } @@ -3389,11 +3773,10 @@ plot.fect <- function(x, #suppressWarnings(print(p)) if(return.test==TRUE){ - return(list(p=p,test.out=test.out)) - } - else{ + return(list(p=p,test.out=test.out)) + } else { return(p) } -} \ No newline at end of file +}