1# File src/library/grDevices/R/prettyDate.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2016 The R Core Team 5# 6# Original code Copyright (C) 2010 Felix Andrews 7# Modifications Copyright (C) 2010 The R Core Team 8# 9# This program is free software; you can redistribute it and/or modify 10# it under the terms of the GNU General Public License as published by 11# the Free Software Foundation; either version 2 of the License, or 12# (at your option) any later version. 13# 14# This program is distributed in the hope that it will be useful, 15# but WITHOUT ANY WARRANTY; without even the implied warranty of 16# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17# GNU General Public License for more details. 18# 19# A copy of the GNU General Public License is available at 20# https://www.R-project.org/Licenses/ 21 22##' S3 method =: pretty.Date() and pretty.POSIXt [in ../NAMESPACE] 23prettyDate <- function(x, n = 5, min.n = n %/% 2, sep = " ", ...) 24{ 25 stopifnot(min.n <= n) 26 isDate <- inherits(x, "Date") 27 x <- as.POSIXct(x) 28 if (isDate) # the timezone *does* matter 29 attr(x, "tzone") <- "GMT" 30 zz <- rx <- range(x, na.rm = TRUE) 31 D <- diff(nzz <- as.numeric(zz)) 32 MIN <- 60 33 HOUR <- MIN * 60 34 DAY <- HOUR * 24 35 YEAR <- DAY * 365.25 36 MONTH <- YEAR / 12 37 makeOutput <- function(at, s, round = TRUE, do) { 38 structure(if(isDate) 39 if(round) as.Date(round(at, units = "days")) else at 40 else as.POSIXct(at), 41 labels = format(at, s$format)) 42 } 43 if(isDate && D <= n * DAY) { # D <= 'n days' & Date ==> use days 44 zz <- as.Date(zz) 45 r <- round(n - D/DAY) 46 m <- max(0, r %/% 2) 47 m2 <- m + (r %% 2) 48 while(length(dd <- seq.Date(zz[1] - m, zz[2] + m2, by = "1 day")) < min.n + 1) 49 if(m < m2) m <- m+1 else m2 <- m2+1 50 return(makeOutput(dd, round = FALSE, ## "1 DSTday" from steps: 51 list(format = paste("%b", "%d", sep = sep)))) 52 } 53 else if(D < 1) { # unique values / sub-second ranges: [? or use "1 ms" steps below?] 54 m <- min(30, max(D == 0, n/2)) 55 zz <- structure(c(floor(nzz[1] - m), ceiling(nzz[2] + m)), 56 class = class(x), tzone = attr(x, "tzone")) 57 } 58 xspan <- as.numeric(diff(zz), units = "secs") 59 ## specify the set of pretty timesteps 60 steps <- 61 list("1 sec" = list(1, format = "%S", start = "mins"), 62 "2 secs" = list(2), 63 "5 secs" = list(5), 64 "10 secs" = list(10), 65 "15 secs" = list(15), 66 "30 secs" = list(30, format = "%H:%M:%S"), 67 "1 min" = list(1*MIN, format = "%H:%M"), 68 "2 mins" = list(2*MIN, start = "hours"), 69 "5 mins" = list(5*MIN), 70 "10 mins" = list(10*MIN), 71 "15 mins" = list(15*MIN), 72 "30 mins" = list(30*MIN), 73 ## "1 hour" = list(1*HOUR), 74 "1 hour" = list(1*HOUR, format = if (xspan <= DAY) "%H:%M" 75 else paste("%b %d", "%H:%M", sep = sep)), 76 "3 hours" = list(3*HOUR, start = "days"), 77 "6 hours" = list(6*HOUR, format = paste("%b %d", "%H:%M", sep = sep)), 78 "12 hours" = list(12*HOUR), 79 "1 DSTday" = list(1*DAY, format = paste("%b", "%d", sep = sep)), 80 "2 DSTdays" = list(2*DAY), 81 "1 week" = list(7*DAY, start = "weeks"), 82 "halfmonth" = list(MONTH/2, start = "months"), 83 ## "1 month" = list(1*MONTH, format = "%b"), 84 "1 month" = list(1*MONTH, format = if (xspan < YEAR) "%b" 85 else paste("%b", "%Y", sep = sep)), 86 "3 months" = list(3*MONTH, start = "years"), 87 "6 months" = list(6*MONTH, format = "%Y-%m"), 88 "1 year" = list(1*YEAR, format = "%Y"), 89 "2 years" = list(2*YEAR, start = "decades"), 90 "5 years" = list(5*YEAR), 91 "10 years" = list(10*YEAR), 92 "20 years" = list(20*YEAR, start = "centuries"), 93 "50 years" = list(50*YEAR), 94 "100 years" = list(100*YEAR), 95 "200 years" = list(200*YEAR), 96 "500 years" = list(500*YEAR), 97 "1000 years" = list(1000*YEAR)) 98 ## carry forward 'format' and 'start' to following steps 99 for (i in seq_along(steps)) { 100 if (is.null(steps[[i]]$format)) 101 steps[[i]]$format <- steps[[i-1]]$format 102 if (is.null(steps[[i]]$start)) 103 steps[[i]]$start <- steps[[i-1]]$start 104 steps[[i]]$spec <- names(steps)[i] 105 } 106 ## crudely work out number of steps in the given interval 107 nsteps <- xspan / vapply(steps, `[[`, numeric(1), 1L, USE.NAMES=FALSE) 108 init.i <- init.i0 <- which.min(abs(nsteps - n)) 109 ## calculate actual number of ticks in the given interval 110 calcSteps <- function(s, lim = range(zz)) { 111 startTime <- trunc_POSIXt(lim[1], units = s$start) ## FIXME: should be trunc() eventually 112 at <- seqDtime(startTime, end = lim[2], by = s$spec) 113 if(anyNA(at)) { at <- at[!is.na(at)]; if(!length(at)) return(at) } 114 r1 <- sum(at <= lim[1]) 115 r2 <- length(at) + 1 - sum(at >= lim[2]) 116 if(r2 == length(at) + 1) { # not covering at right -- add point at right 117 nat <- seqDtime(at[length(at)], by = s$spec, length=2)[2] 118 if(is.na(nat) || !(nat > at[length(at)])) # failed 119 r2 <- length(at) 120 else 121 at[r2] <- nat 122 } 123 ## Now we could see if we are *smaller* than 'n+1' and add even more at[] on both sides 124 at[r1:r2] 125 } 126 init.at <- calcSteps(st.i <- steps[[init.i]]) 127 ## bump it up if below acceptable threshold 128 R <- TRUE # R := TRUE iff "right" 129 L.fail <- R.fail <- FALSE 130 while ((init.n <- length(init.at) - 1L) < min.n) { 131 if(init.i == 1L) { ## keep steps[[1]] 132 ## add new interval right or left 133 if(R) { 134 nat <- seqDtime(init.at[length(init.at)], by = st.i$spec, length=2)[2] 135 R.fail <- is.na(nat) || !(nat > init.at[length(init.at)]) 136 if(!R.fail) 137 init.at[length(init.at) + 1] <- nat 138 } else { # left 139 nat <- seqDtime(init.at[1], by = paste0("-",st.i$spec), length=2)[2] 140 L.fail <- is.na(nat) || !(nat < init.at[1]) 141 if(!L.fail) { 142 init.at[seq_along(init.at) + 1] <- init.at 143 init.at[1] <- nat 144 } 145 } 146 if(R.fail && L.fail) 147 stop("failed to add more ticks; 'min.n' too large?") 148 R <- !R # alternating right <-> left 149 } else { # smaller step sizes 150 init.i <- init.i - 1L 151 init.at <- calcSteps(st.i <- steps[[init.i]]) 152 } 153 } 154 if (init.n == n) ## perfect 155 return(makeOutput(init.at, st.i)) 156 ## else : have a difference dn : 157 dn <- init.n - n 158 if(dn > 0L) { ## too many ticks 159 ## ticks "outside", on left and right, keep at least one on each side 160 nl <- sum(init.at <= rx[1]) - 1L 161 nr <- sum(init.at >= rx[2]) - 1L 162 if(nl > 0L || nr > 0L) { 163 n.c <- nl+nr # number of removable ticks 164 if(dn < n.c) { # remove dn, not all 165 nl <- round(dn * nl/n.c) 166 nr <- dn - nl 167 } 168 ## remove nl on left, nr on right: 169 init.at <- init.at[-c(seq_len(nl), length(init.at)+1L-seq_len(nr))] 170 } 171 } else { ## too few ticks 172 ## warning("trying to add more points -- not yet implemented") 173 ## but after all, 'n' is approximate 174 ## init.at <- calcSteps(st.i, "more ticks") 175 } 176 if ((dn <- length(init.at) - 1L - n) == 0L ## perfect 177 || (dn > 0L && init.i < init.i0) # too many, but we tried init.i + 1 already 178 || (dn < 0L && init.i == 1)) # too few, but init.i = 1 179 return(makeOutput(init.at, st.i)) 180 181 new.i <- if (dn > 0L) ## too many ticks 182 min(init.i + 1L, length(steps)) 183 else ## too few ticks (and init.i > 1): 184 init.i - 1L 185 new.at <- calcSteps(steps[[new.i]]) 186 new.n <- length(new.at) - 1L 187 ## work out whether new.at or init.at is better 188 if (new.n < min.n) 189 new.n <- -Inf 190 if (abs(new.n - n) < abs(dn)) 191 makeOutput(new.at, steps[[new.i]]) 192 else 193 makeOutput(init.at, st.i) 194} 195 196 197## Utility, a generalization/special case of seq.POSIXct() / seq.Date() 198seqDtime <- function(beg, end, by, length=NULL) { 199 if(missing(by) || !identical(by, "halfmonth")) 200 return( seq(beg, end, by = by, length.out=length) ) 201 ## else by == "halfmonth" => can only go forward (!) 202 if(is.null(length)) { 203 l2 <- NULL; i <- TRUE 204 } else { 205 l2 <- ceiling(length/2); i <- seq_len(length) 206 } 207 at <- seq(beg, end, by = "months", length.out = l2) 208 at2 <- as.POSIXlt(at) 209 stopifnot(length(md <- unique(at2$mday)) == 1) 210 at <- as.POSIXct(at) 211 ## intersperse at and at2 := 15-day-shifted( at ), via rbind(): 212 if(md == 1) { 213 at2$mday <- 15L 214 } else if(md >= 15) { # (md == 16 may happen; not seen yet) 215 at2$mday <- 1L 216 at2$mon <- at2$mon + 1L 217 ## at2 now has wrong 'yday','wday',.. and we rely on as.POSIXct(): 218 } else if(md < 15) { ## e.g., southern hemisphere, seen 14 219 at2$mday <- md + 14L # consistent w (1 -> 15) in 1st case; ok even in Feb. 220 } 221 at2$isdst <- -1L 222 at2 <- rbind(at, as.POSIXct(at2), deparse.level = 0L) 223 structure(at2[i], class = class(at), tzone = attr(at, "tzone")) 224} 225 226 227## utility function, extending the base function trunc.POSIXt. 228## Ideally this should replace the original, but that should be done 229## with a little more thought (what about round.POSIXt etc.?) 230 231trunc_POSIXt <- 232 function(x, units = c("secs", "mins", "hours", "days", 233 "weeks", "months", "years", "decades", "centuries"), 234 start.on.monday = TRUE) 235{ 236 x <- as.POSIXlt(x) 237 if (units %in% c("secs", "mins", "hours", "days")) 238 return(trunc.POSIXt(x, units)) 239 x <- trunc.POSIXt(x, "days") 240 if (length(x$sec)) 241 switch(units, 242 weeks = { 243 x$mday <- x$mday - x$wday 244 if (start.on.monday) 245 x$mday <- x$mday + ifelse(x$wday > 0L, 1L, -6L) 246 }, 247 months = { 248 x$mday <- 1 249 }, 250 years = { 251 x$mday <- 1 252 x$mon <- 0 253 }, 254 decades = { 255 x$mday <- 1 256 x$mon <- 0 257 x$year <- (x$year %/% 10) * 10 258 }, 259 centuries = { 260 x$mday <- 1 261 x$mon <- 0 262 x$year <- (x$year %/% 100) * 100 263 }) 264 x 265} 266