@@ -172,6 +172,139 @@ plot_moderator_c_loess <- function(.model, moderator, line_color = 'blue'){
172172return (p )
173173}
174174
175+
176+ # ' @title Auto-Bin a plot of a continuous moderating variable into a discrete moderating variable
177+ # ' @description Use a regression tree to optimally bin a continous variable
178+ # '
179+ # ' @param .model a model produced by `bartCause::bartc()`
180+ # ' @param moderator the moderator as a vector
181+ # ' @param .alpha transparency value [0, 1]
182+ # ' @param facet TRUE/FALSE. Create panel plots of each moderator level?
183+ # ' @param .ncol number of columns to use when faceting
184+ # ' @param type string to specify if you would like to plot a histogram, density or error bar plot
185+ # '@param .name sting representing the name of the moderating variable
186+ # '
187+ # ' @author George Perrett
188+ # '
189+ # '
190+ # ' @return ggplot object
191+ # ' @export
192+ # '
193+ # ' @import ggplot2 dplyr
194+ # ' @importFrom bartCause extract
195+ # ' @importFrom rpart rpart
196+ # '
197+ # ' @examples
198+ # ' \donttest{
199+ # ' data(lalonde)
200+ # ' confounders <- c('age', 'educ', 'black', 'hisp', 'married', 'nodegr')
201+ # ' model_results <- bartCause::bartc(
202+ # ' response = lalonde[['re78']],
203+ # ' treatment = lalonde[['treat']],
204+ # ' confounders = as.matrix(lalonde[, confounders]),
205+ # ' estimand = 'ate',
206+ # ' commonSuprule = 'none'
207+ # ' )
208+ # ' plot_moderator_c_bin(model_results, lalonde$age, .name = 'age')
209+ # ' }
210+ plot_moderator_c_bin <- function (.model ,moderator ,type = c(' density' ' histogram' ' errorbar' .alpha = 0.7 ,facet = FALSE ,.ncol = 1 ,.name = ' bin'
211+
212+ validate_model_(.model )
213+ is_numeric_vector_(moderator )
214+ type <- type [1 ]
215+
216+ # adjust moderator to match estimand
217+ moderator <- adjust_for_estimand_(.model ,moderator )
218+ estimand <- switch (.model $ estimand ,
219+ ate = ' CATE'
220+ att = ' CATT'
221+ atc = ' CATC'
222+ )
223+ # extract the posterior
224+ posterior <- bartCause :: extract(.model ,' icate'
225+
226+ # get icate point est
227+ icate.m <- apply(posterior ,2 ,mean )
228+
229+ # fit regression tree
230+ tree <- rpart :: rpart(icate.m ~ moderator )
231+
232+ # get bins from regression tree
233+ bins <- dplyr :: tibble(splits = tree $ where )
234+ subgroups <- dplyr :: tibble(splits = tree $ where ,
235+ x = moderator ) %> %
236+ dplyr :: group_by(splits ) %> %
237+ dplyr :: summarise(min = min(x ),max = max(x )) %> %
238+ dplyr :: arrange(min ) %> %
239+ dplyr :: mutate(subgroup = paste0(.name ,' :' min ,' -' max ))
240+
241+ bins <- bins %> %dplyr :: left_join(subgroups )
242+
243+ # roatate posterior
244+ posterior <- posterior %> %
245+ t() %> %
246+ as.data.frame() %> %
247+ as_tibble()
248+
249+ # split posterior into list of dfs by each level of moderator
250+ split_posterior <- split(posterior ,bins $ subgroup )
251+ posterior_means <- lapply(split_posterior ,colMeans )
252+
253+ # unlist into a data.frame for plotting
254+ dat <- data.frame (value = unlist(posterior_means ))
255+ dat $ moderator <- sub(" \\ ..*" ' ' dat ))
256+ rownames(dat )<- seq_len(nrow(dat ))
257+
258+ # plot it
259+ p <- ggplot(dat , aes(value ,fill = moderator ))
260+
261+ if (type == ' density'
262+ p <- p + geom_density(alpha = .alpha )+
263+ labs(title = NULL ,
264+ x = estimand ,
265+ y = NULL )+
266+ theme(legend.position = ' bottom'
267+ }else if (type == ' histogram'
268+ p <- p +
269+ geom_histogram(
270+ alpha = .alpha ,
271+ col = ' black'
272+ position = ' identity' +
273+ labs(title = NULL ,
274+ x = estimand ,
275+ y = NULL )+
276+ theme(legend.position = ' bottom'
277+ }else {
278+ # tidy up the data
279+ dat <- dat %> %
280+ group_by(moderator ) %> %
281+ mutate(.min = quantile(value ,.025 ),
282+ .max = quantile(value ,.975 ),
283+ point = mean(value )) %> %
284+ dplyr :: select(- value ) %> %
285+ arrange(desc(point )) %> %
286+ ungroup() %> %
287+ distinct()
288+
289+ # plot it
290+ p <- ggplot(dat , aes(x = moderator ,y = point ,color = moderator ))+
291+ geom_point(size = 2 )+
292+ geom_linerange(aes(ymin = .min ,ymax = .max ),alpha = .alpha )+
293+ labs(title = NULL ,
294+ x = element_blank(),
295+ y = estimand )+
296+ theme(legend.position = ' bottom'
297+ }
298+
299+
300+ # add faceting
301+ if (isTRUE(facet )){
302+ p <- p + facet_wrap(~ moderator ,ncol = .ncol )
303+ }
304+
305+ return (p )
306+ }
307+
175308# ' @title Plot the Conditional Average Treatment Effect conditional on a discrete moderator
176309# ' @description Plot the Conditional Average Treatment Effect split by a discrete moderating variable. This plot will provide a visual test of moderation by discrete variables.
177310# '