R/barcharts.R

In mlhutchins/fast-analytics: Fast Prototyping of Analysis Scripts

#' Network technology bar chart
#'
#' Stacked barchart of the network technology used during download tests for
#' each carrier.
#'
#' @return Returns standard fast-analysis structured list
#' @family skeletonPlots
#' @export
networkTechnologyBar <- function() {

    save <- 'network_technology_bar'
    data <- pullFilteredTestSummary()

    process <- "
## Put network technologies into the correct order
filtered$network_technology <- factor(filtered$network_technology,
                                      levels = c('LTE', '3G+', '2G/3G', 'Mixed', 'Unknown'))"

    plot <- "
#### Network Technology Bar Chart
df <- filtered[filtered$test_type_id %in% c(13, 19, 20, 21), ]
plt <- ggplot(df, aes(x = carrier,
                        fill = network_technology)) +
    geom_bar(stat = 'bin', position = 'fill') +
    scale_fill_root() +
    theme_root() +
    xlab('') +
    scale_y_continuous(labels = percent) +
    ylab('')
print(plt)"

    ## Append a line for saving the plot in the standard format
    plot <- paste(plot,
                  saveLine(save),
                  sep = "")
    output <- list(data = data,
                   process = process,
                   plot = plot,
                   save = save)
    return(output)

}

#' Call Failure Bar Chart
#'
#' Faceted plot for blocks, drops, total, facetted over call type
#'
#' @export
#' @family skeletonPlots
#' @return Returns standard fast-analysis structured list
callFailureBarChart <- function() {

    save <- "call_failure_barchart"
    data <- pullCallStats()

    plot <- "
#### Call Failure Bar Chart
df <- melt(callStats, id.vars = c('carrier', 'test_type'),
           measure.vars = c('is_drop', 'is_block'))
df <- ddply(df, .(carrier, test_type, variable), summarize,
            rate = sum(value & !is.na(value)) / sum(!is.na(value)),
            ul = getCI(value, func = 'mean')$upper,
            ll = getCI(value, func = 'mean')$lower)
df$variable <- as.character(df$variable)
df$variable[df$variable == 'is_drop'] <- 'Drop'
df$variable[df$variable == 'is_block'] <- 'Block'
df$variable <- factor(df$variable, levels = c('Block', 'Drop'))
plt <- ggplot(df, aes(x = variable,
                      y = rate,
                        fill = carrier )) +
    geom_bar(stat = 'identity', position = 'dodge') +
    geom_errorbar(aes(ymax = ul, ymin = ll), position = 'dodge') +
    scale_fill_root() +
    theme_root() +
    xlab('') +
    scale_y_continuous(labels = percent) +
    ylab('') +
    facet_grid(~ test_type)
print(plt)"

    ## Append a line for saving the plot in the standard format
    plot <- paste(plot,
                  saveLine(save),
                  sep = "")

    output <- list(data = data,
                   plot = plot,
                   save = save)
    return(output)

}

#' Executive Summary Style RootScores
#'
#' Sidewise bar charts of rootscore with ranks and scores.  These plots are
#' not automatically included into the TeX file.  If there are no rootscores
#' in the database then they should be calculated locally with
#' \code{\link{bootscorer}}.
#'
#' @export
#' @family skeletonPlots
#' @return Returns standard fast-analysis structured list
execRootscores <- function() {

    data <- pullRootScores()
    save <- "rootscore_exec_barchart"

    plot <- sprintf("
#### Executive RootScore Summary
sideBar <- function(scoreType) {

    data <- rootscores[rootscores$score_type == scoreType,]

    data$carrier <-  factor(data$carrier, levels = data$carrier[order(-data$rank, data$score)])

    data$text <- paste(sprintf('%%.1f', 100 * data$score, digits = 1))

    p <- ggplot(data,
           aes(x = carrier,
               y = 100 * score,
               ymax = 100 * ul_95,
               ymin = 100 * ll_05,
               fill = carrier)) +
        geom_bar(stat = 'identity') +
        geom_errorbar(width = 0.5) +
        geom_text(aes(label = text, y = 101), hjust = 0) +
        geom_text(aes(label = rank, y = 100 * ll_05), color = 'white', hjust = 2) +
        theme_root() +
        theme(panel.border = element_blank(),
              panel.grid.major = element_blank(),
              panel.grid.minor = element_blank(),
              axis.ticks.y=element_blank()) +
        scale_fill_root(guide = 'none') +
        coord_flip(ylim = c(50, 105)) +
        ylab('') +
        xlab('')
    print(p)

    fileName <- paste(figureDir, sprintf('%s_%%s', scoreType), '.png', sep = '')
    dev.copy(png, fileName, width = 8, height = 2, units = 'in', res = 400)
    dev.off()

}

if (nrow(rootscores) == 0) {
    warning('No RootScores in database, calculate locally')
} else {
    lapply(unique(rootscores$score_type), sideBar)
}", save)

    output <- list(data = data,
                   plot = plot)
    return(output)

}

#' RootScores Bar Chart
#'
#' Bar chart of the rootscores for every carrier/test.  If there are no rootscores
#' in the database then they should be calculated locally with
#' \code{\link{bootscorer}}.
#'
#' @export
#' @family skeletonPlots
#' @return Returns standard fast-analysis structured list
rootscoreBarChart <- function() {

    data <- pullRootScores()
    save <- "rootscore_barchart"

    plot <- "
#### RootScore Summary
plt <- ggplot(rootscores,
			  aes(x = score_type,
			  	y = 100 * score,
			  	ymin = 100 * ll_05,
			  	ymax = 100 * ul_95,
			  	fill = carrier)) +
	geom_bar(stat = 'identity', position = 'dodge') +
	geom_text(aes(label = rank, y = 100 * ul_95),
			  position = position_dodge(0.9),
			  vjust = -0.5) +
	geom_errorbar(position = 'dodge') +
	scale_fill_root() +
	theme_root() +
	xlab('') +
	ylab('RootScore') +
	coord_cartesian(ylim = 100 * c(0, 1 + 0.19))


if (nrow(rootscores) == 0) {
    warning('No RootScores in database, calculate locally')
    plt <- ggplot(data.frame(x = 1, y = 1),
                  aes(x = x, y = y)) +
        geom_text(label = 'No Local RootScores') + theme_bw()
    print(plt)
} else {
    print(plt)
}"

    plot <- paste(plot,
                  saveLine(save),
                  sep = "")

    output <- list(data = data,
                   plot = plot,
                   save = save)
    return(output)

}