-
Notifications
You must be signed in to change notification settings - Fork 207
/
accessors-month.r
152 lines (135 loc) · 4.47 KB
/
accessors-month.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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
#' @include periods.r
NULL
#' Get/set months component of a date-time
#'
#' Date-time must be a POSIXct, POSIXlt, Date, Period, chron, yearmon, yearqtr, zoo,
#' zooreg, timeDate, xts, its, ti, jul, timeSeries, and fts objects.
#'
#' @param x a date-time object
#' @param label logical. TRUE will display the month as a character string such
#' as "January." FALSE will display the month as a number.
#' @param abbr logical. FALSE will display the month as a character string
#' label, such as "January". TRUE will display an abbreviated version of the
#' label, such as "Jan". abbr is disregarded if label = FALSE.
#' @param value a numeric object
#' @param locale for month, locale to use for month names. Default to current locale.
#' @return If `label = FALSE`: month as number (1-12, 1 = January, 12 = December),
#' otherwise as an ordered factor.
#' @keywords utilities manip chron methods
#' @examples
#' x <- ymd("2012-03-26")
#' month(x)
#' month(x) <- 1
#' month(x) <- 13
#' month(x) > 3
#'
#' month(ymd(080101))
#' month(ymd(080101), label = TRUE)
#' month(ymd(080101), label = TRUE, abbr = FALSE)
#' month(ymd(080101) + months(0:11), label = TRUE)
#' @export
month <- function(x, label = FALSE, abbr = TRUE, locale = Sys.getlocale("LC_TIME")) {
UseMethod("month")
}
#' @export
month.default <- function(x, label = FALSE, abbr = TRUE, locale = Sys.getlocale("LC_TIME")) {
month(as.POSIXlt(x, tz = tz(x))$mon + 1, label, abbr, locale = locale)
}
#' @export
month.numeric <- function(x, label = FALSE, abbr = TRUE, locale = Sys.getlocale("LC_TIME")) {
if (!all(x[!is.na(x)] %in% 1:12)) {
stop("Values are not in 1:12")
}
if (!label) {
return(x)
}
names <- .get_locale_regs(locale)$month_names
labels <- if (abbr) names$abr else names$full
ordered(x, levels = 1:12, labels = labels)
}
#' @export
month.Period <- function(x, label = FALSE, abbr = TRUE, locale = Sys.getlocale("LC_TIME")) {
slot(x, "month")
}
as_month <- function(value) {
## FIXME: use same technique as in as_week_start to localize this
if (is.character(value)) {
value <- pmatch(
tolower(value),
c(
"january", "february", "march",
"june", "july", "august", "september",
"october", "november", "december"
)
)
}
value
}
#' @rdname month
#' @export
setGeneric("month<-",
function (x, value) standardGeneric("month<-"),
useAsDefault = function(x, value) {
y <- update_datetime(as.POSIXct(x), months = value, roll_month = "NAym")
reclass_date(y, x)
}
)
#' @export
setMethod("month<-", "Duration", function(x, value) {
x <- x + months(as_month(value) - month(x))
})
#' @export
setMethod("month<-", signature("Period"), function(x, value) {
slot(x, "month") <- as_month(value)
x
})
#' @export
setMethod("month<-", "Interval", function(x, value) {
x <- x + months(as_month(value) - month(x))
})
#' @export
setMethod("month<-", "POSIXt", function(x, value) {
update_datetime(x, months = value, roll_month = "NAym")
})
#' @export
setMethod("month<-", "Date", function(x, value) {
update_datetime(x, months = value, roll_month = "NAym")
})
#' Get the number of days in the month of a date-time
#'
#' Date-time must be a POSIXct, POSIXlt, Date, chron, yearmon, yearqtr,
#' zoo, zooreg, timeDate, xts, its, ti, jul, timeSeries, and fts objects.
#'
#' @export
#' @param x a date-time object
#' @return An integer of the number of days in the month component of the date-time object.
days_in_month <- function(x) {
month_x <- month(x, label = TRUE, locale = "C")
n_days <- N_DAYS_IN_MONTHS[month_x]
n_days[month_x == "Feb" & leap_year(x)] <- 29L
n_days
}
## fixme: integrate with above, this oen is needed internally
.days_in_month <- function(m, y) {
n_days <- N_DAYS_IN_MONTHS[m]
n_days[m == 2L & leap_year(y)] <- 29L
n_days
}
## tothink: export?
days_in_months_so_far <- function(month, leap) {
## if month is negative, compute from the end of the year
cum_days_pos <- c(0, cumsum(N_DAYS_IN_MONTHS)[-12])
cum_days_neg <- c(0, cumsum(rev(N_DAYS_IN_MONTHS))[-12])
negative <- month < 0
positive <- month > 0
sofar <- integer(length(month))
sofar[negative] <- cum_days_neg[-month[negative]]
sofar[positive] <- cum_days_pos[month[positive]]
adjust <- leap & ((negative & month == -12) | (positive & month > 2))
sofar[adjust] <- sofar[adjust] + 1L
sofar
}
## days_in_months_so_far(c(1, 2, 3, -10, -11, -12), rep.int(T, 6))
## [1] 0 31 60 275 306 335
## days_in_months_so_far(c(1, 2, 3, -10, -11, -12), rep.int(F, 6))
## [1] 0 31 59 275 306 334