Skip to content
This repository
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 144 lines (132 sloc) 5.08 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
##' Tufte's Box Blot
##'
##' Edward Tufte's revision of the box plot erases the box and
##' replaces it with a single point and the whiskers.
##'
##' @section Aesthetics:
##' \Sexpr[results=rd,stage=build]{ggthemes:::rd_aesthetics("geom_tufteboxplot", ggthemes:::GeomTufteboxplot)}
##'
##' @references Tufte, Edward R. (2001) The Visual Display of
##' Quantitative Information, Chapter 6.
##'
##' McGill, R., Tukey, J. W. and Larsen, W. A. (1978) Variations of
##' box plots. The American Statistician 32, 12-16.
##'
##' @seealso \code{\link{geom_boxplot}}
##' @inheritParams ggplot2::geom_point
##' @param outlier.colour colour for outlying points
##' @param outlier.shape shape of outlying points
##' @param outlier.size size of outlying points
##' @param fatten a multiplicative factor to fatten the middle point
##' (or line) by
##' @param usebox use a box to represent the standard error of the median;
##' the same thing as the notch does in a standard boxplot.
##' @param boxwidth a number between 0 and 1 which represents the
##' relative width of the box to the middle line.
##' @family geom tufte
##' @export
##'
##' @examples
##' p <- ggplot(mtcars, aes(factor(cyl), mpg))
##' ## with only a point
##' p + geom_tufteboxplot()
##' ## with a middle box
##' p + geom_tufteboxplot(usebox=TRUE, fatten=1)
##'
geom_tufteboxplot <- function (mapping = NULL, data = NULL, stat = "boxplot",
                               position = "dodge",
                               outlier.colour = "black", outlier.shape = 16,
                               outlier.size = 2, fatten=4,
                               usebox=FALSE, boxwidth=0.25, ...) {
    GeomTufteboxplot$new(mapping = mapping, data = data, stat = stat,
                         position = position, outlier.colour = outlier.colour,
                         outlier.shape = outlier.shape,
                         outlier.size = outlier.size, fatten=fatten,
                         usebox=usebox, boxwidth=boxwidth,
                         ...)
}

GeomTufteboxplot <- proto(ggplot2:::Geom, {
  objname <- "tufteboxplot"

  reparameterise <- function(., df, params) {
    df$width <- (df$width %||%
                 params$width %||%
                 (resolution(df$x, FALSE) * 0.1))
    if (!is.null(df$outliers)) {
      suppressWarnings({
        out_min <- vapply(df$outliers, min, numeric(1))
        out_max <- vapply(df$outliers, max, numeric(1))
      })
      df$ymin_final <- pmin(out_min, df$ymin)
      df$ymax_final <- pmax(out_max, df$ymax)
    }
    df <- transform(df,
              xmin = x - width / 2,
              xmax = x + width / 2,
              width = NULL
    )
    df
  }

  draw <- function(., data, ..., outlier.colour = NULL,
                   outlier.shape = NULL, outlier.size = 2, fatten=4, usebox=FALSE, boxwidth=0.05) {
    common <- data.frame(
        colour = data$colour,
        size = data$size,
        linetype = data$linetype,
        fill = alpha(data$fill, data$alpha),
        group = NA,
        stringsAsFactors = FALSE
    )

    whiskers <- data.frame(
      x = data$x,
      xend = data$x,
      y = c(data$upper, data$lower),
      yend = c(data$ymax, data$ymin),
      alpha = NA,
      common)

    if (usebox) {
        convexcomb <- function(a, x1, x2) {a * x1 + (1 - a) * x2}

        boxdata <-
            data.frame(
                xmin = convexcomb(boxwidth, data$xmin, data$x),
                xmax = convexcomb(boxwidth, data$xmax, data$x),
                ymin = data$notchlower,
                ymax = data$notchupper,
                alpha = data$alpha,
                common)
        box_grob <- GeomRect$draw(boxdata, ...)
        middle_grob <- GeomSegment$draw(transform(data,
                                                  x=xmin, xend=xmax,
                                                  y=middle, yend=middle,
                                                  size=size * fatten), ...)
    } else {
        box_grob <- NULL
        middle_grob <- GeomPoint$draw(transform(data, y=middle,
                                                size=size * fatten), ...)
    }

    if (!is.null(data$outliers) && length(data$outliers[[1]] >= 1)) {
      outliers <- data.frame(
          y = data$outliers[[1]],
          x = data$x[1],
          colour = outlier.colour %||% data$colour[1],
          shape = outlier.shape %||% data$shape[1],
          size = outlier.size %||% data$size[1],
          fill = NA,
          alpha = NA,
          stringsAsFactors = FALSE)
      outliers_grob <- GeomPoint$draw(outliers, ...)
    } else {
      outliers_grob <- NULL
    }

    ggname(.$my_name(), grobTree(
        outliers_grob,
        box_grob,
        GeomSegment$draw(whiskers, ...),
        middle_grob
        ))
  }

  guide_geom <- function(.) "pointrange"
  default_stat <- function(.) StatBoxplot
  default_pos <- function(.) PositionDodge
  default_aes <- function(.) aes(colour = "black", size=0.5, linetype=1, shape=16, fill="gray20", alpha = NA)
  required_aes <- c("x", "lower", "upper", "middle", "ymin", "ymax")

})

Something went wrong with that request. Please try again.