|
| 1 | +#' gsplot date axis |
| 2 | +#' |
| 3 | +#' Special axis for date handling, including interval labelling. |
| 4 | +#' |
| 5 | +#' @param object gsplot object |
| 6 | +#' @param \dots Further graphical parameters may also be supplied as arguments. See 'Details'. |
| 7 | +#' @details Additional graphical parameter inputs: |
| 8 | +#' \itemize{ |
| 9 | +#' \item{\code{pos.lab}} {where should the label be positioned, centered on the "tick" or "interval".} |
| 10 | +#' \item{\code{tick.int}} {interval in which ticks should be placed, alternative to defining at.} |
| 11 | +#' \item{\code{snap.to}} {set the limits to coincide with temporal boundaries. Accepts "day", "week", "month", "quarter", |
| 12 | +#' "year", "wateryear", "decade".} |
| 13 | +#' } |
| 14 | +#' |
| 15 | +#' @rdname date_axis |
| 16 | +#' @export |
| 17 | +#' @examples |
| 18 | +#' x <- seq(as.Date("2013-01-22"), as.Date("2013-10-02"), "days") |
| 19 | +#' y <- rnorm(length(x), 71, 19) |
| 20 | +#' gs <- gsplot() %>% |
| 21 | +#' points(x, y) %>% |
| 22 | +#' date_axis(side=1, pos.lab="interval", tick.int="month", snap.to="year") |
| 23 | +#' gs |
| 24 | +#' |
| 25 | +#' x <- seq(as.POSIXct("1992-03-03 06:00:00"), as.POSIXct("1992-03-08 12:00:00"), "hour") |
| 26 | +#' y <- rnorm(length(x), 19, 2) |
| 27 | +#' gs <- gsplot() %>% |
| 28 | +#' points(x, y) %>% |
| 29 | +#' date_axis(side=1, pos.lab="tick", tick.int="day", snap.to="day", format="%D") |
| 30 | +#' gs |
| 31 | +date_axis <- function(object, ...) { |
| 32 | + override("gsplot", "date_axis", object, ...) |
| 33 | +} |
| 34 | + |
| 35 | +#' @param side side to place the axis on |
| 36 | +#' @param pos.lab where should the label be positioned, centered on the "tick" or "interval". |
| 37 | +#' @param at specific location to place ticks |
| 38 | +#' @param tick.int interval in which ticks should be placed, alternative to defining at. |
| 39 | +#' @param snap.to set the limits to coincide with temporal boundaries. Accepts "day", "week", "month", "quarter", |
| 40 | +#' "year", "wateryear", "decade". |
| 41 | +#' |
| 42 | +#' @rdname date_axis |
| 43 | +#' @export |
| 44 | +date_axis.gsplot <- function(object, ..., side, pos.lab="tick", at=NULL, tick.int=NULL, snap.to="day") { |
| 45 | + if (exists("at") &&!is.null(at) && !is.null(tick.int)) { |
| 46 | + warning("cannot specify both at and tick.int, at will be ignored") |
| 47 | + } |
| 48 | + if (!is.null(tick.int)) { |
| 49 | + ticksAt <- lazy({ |
| 50 | + # calc ticks |
| 51 | + limit <- lim(object, side) |
| 52 | + # TODO: handle -ly on tick.int |
| 53 | + seq(limit[1], limit[2], tick.int) |
| 54 | + }) |
| 55 | + } else if (exists("at") && !is.null(at)) { |
| 56 | + ticksAt <- at |
| 57 | + } else { |
| 58 | + ticksAt <- NULL |
| 59 | + } |
| 60 | + |
| 61 | + labelsAt <- lazy({ |
| 62 | + labels <- NULL |
| 63 | + limit <- lim(object, side) |
| 64 | + |
| 65 | + if (is.null(ticksAt)) { |
| 66 | + main.ticks <- grid_axTicks(object, side) |
| 67 | + } else if (inherits(ticksAt, "lazy")) { |
| 68 | + main.ticks <- lazy_eval(ticksAt, data=list(object=object)) |
| 69 | + } else { |
| 70 | + main.ticks <- ticksAt |
| 71 | + } |
| 72 | + |
| 73 | + if (pos.lab == "tick") { |
| 74 | + labels <- main.ticks |
| 75 | + } else if (pos.lab == "interval") { |
| 76 | + all.ints <- c(limit[1], main.ticks, limit[2]) |
| 77 | + for (i in 2:length(all.ints)) { |
| 78 | + prev = all.ints[i-1] |
| 79 | + curr = all.ints[i] |
| 80 | + if (curr != prev) { |
| 81 | + label <- prev + (curr-prev) / 2 |
| 82 | + if (is.null(labels)) labels <- label |
| 83 | + else labels <- c(labels, label) |
| 84 | + } |
| 85 | + } |
| 86 | + } else { |
| 87 | + stop("pos.lab must be \"tick\" or \"interval\"") |
| 88 | + } |
| 89 | + return(labels) |
| 90 | + }) |
| 91 | + snapTo <- lazy({ |
| 92 | + old.lim <- lim(object, side) |
| 93 | + # TODO: handle start.on.monday=TRUE use %u instead of %w and offset 1 |
| 94 | + limit <- switch(snap.to, |
| 95 | + "day" = day_period(old.lim), |
| 96 | + "week" = week_period(old.lim), |
| 97 | + "month" = month_period(old.lim), |
| 98 | + "quarter" = quarter_period(old.lim), |
| 99 | + "year" = year_period(old.lim), |
| 100 | + "wateryear" = wateryear_period(old.lim), |
| 101 | + "decade" = decade_period(old.lim), |
| 102 | + old.lim # default |
| 103 | + ) |
| 104 | + }) |
| 105 | + |
| 106 | + object <- axis(object, ..., side, at=ticksAt, labels=FALSE) |
| 107 | + object <- axis(object, ..., side, at=labelsAt, tick=FALSE, append=TRUE) |
| 108 | + for (side_name in as.side_name(side)) { |
| 109 | + object[[side_name]][["snap.to"]] <- snapTo |
| 110 | + } |
| 111 | + return(object) |
| 112 | +} |
| 113 | + |
| 114 | +#' @rdname date_axis |
| 115 | +#' @export |
| 116 | +date_axis.default <- function(side, pos.lab="tick", tick.int=NULL, snap.to=NULL, ...) { |
| 117 | + warning("date_axis is not implemented for base graphics plots") |
| 118 | + return() |
| 119 | +} |
| 120 | + |
0 commit comments