geom_drilldown.R

GeomDrilldownLabel <- ggproto("GeomDrilldownLabel", GeomLabel,
                             extra_params = c("na.rm"),
                             required_aes = c("x", "y","label"),
                             setup_data = function(data, params) {
                               as.data.frame(dplyr::mutate(dplyr::group_by(data,x,PANEL),y=cumsum(y)-y/2))
                             }
                             
)
geom_drilldown_label <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity",
                                ..., na.rm = TRUE, show.legend = NA, inherit.aes = TRUE){
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomDrilldownLabel,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(na.rm=na.rm,...)
  )
}

GeomDrilldownText <- ggproto("GeomDrilldownText", GeomText,
                       extra_params = c("na.rm"),
                       required_aes = c("x", "y","label"),
                       setup_data = function(data, params) {
                         as.data.frame(dplyr::mutate(dplyr::group_by(data,x,PANEL),y=cumsum(y)-y/2))
                       }
                       
)
geom_drilldown_text <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity",
                           ..., na.rm = TRUE, show.legend = NA, inherit.aes = TRUE){
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomDrilldownText,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(na.rm=na.rm,...)
  )
}

geom_drilldown <- function(mapping = NULL, data = NULL, stat = "identity", position = "stack",
                                ..., width = 1, colour="grey", size=1, na.rm = TRUE, show.legend = NA, inherit.aes = TRUE){
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomCol,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, width = width, colour = colour, size = size,...)
  )
}


make_drilldown <- function(data,dimensions,metrics){
len <- length(dimensions)
out <- vector("list",len)
dat1 <- as.data.frame(dplyr::summarize_each_(dplyr::group_by_(data, dimensions[1]),dplyr::funs(sum),metrics))
dat1$level <- dat1[,1]
dat1 <- setNames(dat1,c("level",metrics,"label"))
dat1 <- dat1[order(dat1$label, decreasing = TRUE),]
dat1$dimensions <- dimensions[1]
out[[1]] <-dat1
if(len>=2){
for(i in 2:len){
  tmp <- as.data.frame(dplyr::summarize_each_(dplyr::group_by_(data, .dots=dimensions[1:i]),dplyr::funs(sum),metrics))
  tmp <- tidyr::unite(tmp,level,1:i,remove=FALSE,sep="__")
  tmp <- tmp[,-c(2:i)]
  tmp <- setNames(tmp,c("level","label",metrics)) 
  tmp <- tmp[order(tmp$level,decreasing = TRUE),]
  tmp$dimensions <- dimensions[i]
  out[[i]] <- tmp
}
}
out_df <- dplyr::bind_rows(out)
out_df$dimensions <- factor(out_df$dimensions,levels = dimensions)
out_df
}