-
Notifications
You must be signed in to change notification settings - Fork 207
/
pretty.r
120 lines (100 loc) · 3.5 KB
/
pretty.r
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
#' Computes attractive axis breaks for date-time data
#'
#' pretty.dates indentifies which unit of time the sub-intervals should be
#' measured in to provide approximately n breaks. It then chooses a "pretty"
#' length for the sub-intervals and sets start and endpoints that 1) span the
#' entire range of the data, and 2) allow the breaks to occur on important
#' date-times (i.e. on the hour, on the first of the month, etc.)
#'
#' @param x a vector of POSIXct, POSIXlt, Date, or chron date-time objects
#' @param n integer value of the desired number of breaks
#' @param ... additional arguments to pass to function
#' @return a vector of date-times that can be used as axis tick marks or bin breaks
#' @keywords dplot utilities chron
#' @export pretty_dates pretty.unit pretty.sec pretty.min pretty.hour pretty.day pretty.month pretty.year pretty.point
#' @aliases pretty.dates pretty.unit pretty.sec pretty.min pretty.hour pretty.day pretty.month pretty.year pretty.point
#' @examples
#' x <- seq.Date(as.Date("2009-08-02"), by = "year", length.out = 2)
#' # "2009-08-02" "2010-08-02"
#' pretty_dates(x, 12)
#' #"2009-08-01 GMT" "2009-09-01 GMT" "2009-10-01 GMT" "2009-11-01 GMT" "2009-12-01 GMT" "2010-01-01 GMT" "2010-02-01 GMT" "2010-03-01 GMT" "2010-04-01 GMT" "2010-05-01 GMT" "2010-06-01 GMT" "2010-07-01 GMT" "2010-08-01 GMT" "2010-09-01 GMT"
pretty_dates <- function(x, n, ...){
remember <- Sys.getenv("TZ")
if (Sys.getenv("TZ") == "")
remember <- "unset"
Sys.setenv(TZ = tz(x[1]))
rng <- range(x)
diff <- as.duration(rng[2] - rng[1])
diff <- as.double(diff, "secs")
binunits <- pretty.unit(diff/n)
f <- match.fun(paste("pretty", binunits, sep = "."))
binlength <- f(diff, n)
start <- pretty.point(min(rng), binunits, binlength)
end <- pretty.point(max(rng), binunits, binlength, start = FALSE)
breaks <- seq.POSIXt(start, end, paste(binlength, binunits))
if (remember == "unset")
Sys.unsetenv("TZ")
else
Sys.setenv(TZ = remember)
breaks
}
pretty.unit <- function(x, ...){
if (x > 3600*24*365)
return("year")
if (x > 3600*24*30)
return("month")
if (x > 3600*24)
return("day")
if (x > 3600)
return("hour")
if (x > 60)
return("min")
else
return("sec")
}
pretty.sec <- function(x, n, ...){
lengths <- c(1,2,5,10,15,30,60)
fit <- abs(x - lengths*n)
lengths[which.min(fit)]
}
pretty.min <- function(x, n, ...){
span <- x/60
lengths <- c(1,2,5,10,15,30,60)
fit <- abs(span - lengths*n)
lengths[which.min(fit)]
}
pretty.hour <- function(x, n, ...){
span <- x / 3600
lengths <- c(1,2,3,4,6,8,12,24)
fit <- abs(span - lengths*n)
lengths[which.min(fit)]
}
pretty.day <- function(x, n, ...){
span <- x / (3600 * 24)
pretty(1:span, n = n)[2]
}
pretty.month <- function(x, n, ...){
span <- x / (3600 * 24 * 30)
lengths <- c(1,2,3,4,6,12)
fit <- abs(span - lengths*n)
lengths[which.min(fit)]
}
pretty.year <- function(x, n, ...){
span <- x / (3600 * 24 * 365)
pretty(1:span, n = n)[2]
}
pretty.point <- function(x, units, length, start = TRUE, ...){
x <- as.POSIXct(x)
floors <- c("sec", "min", "hour", "day", "d", "month", "year", "y")
floorto <- floors[which(floors == units) + 1]
lower <- floor_date(x, floorto)
upper <- ceiling_date(x, floorto)
points <- seq.POSIXt(lower, upper, paste(length, units))
if (start)
points <- points[points <= x]
else
points <- points[points >= x]
fit <- as.duration(x - points)
fit <- abs(as.double(fit, "secs"))
return(points[which.min(fit)])
}