diff --git a/NEWS.md b/NEWS.md index 9421f96400..00c96d0621 100644 --- a/NEWS.md +++ b/NEWS.md @@ -72,6 +72,8 @@ 12. `print(..., col.names = 'none')` now correctly adapts column widths to the data content, ignoring the original column names and producing a more compact output, [#6882](https://github.com/Rdatatable/data.table/issues/6882). Thanks to @brooksambrose for the report and @venom1204 for the PR. +13. `as.IDate()` and `as.ITime()` now preserve names, matching base `as.Date()` behavior, [#7252](https://github.com/Rdatatable/data.table/issues/7252). Thanks @DavisVaughan for the report and @venom1204 for the PR. + ### NOTES 1. The following in-progress deprecations have proceeded: diff --git a/R/IDateTime.R b/R/IDateTime.R index 383ceb54e7..8bb6af387f 100644 --- a/R/IDateTime.R +++ b/R/IDateTime.R @@ -5,6 +5,11 @@ as.IDate = function(x, ...) UseMethod("as.IDate") +copy_names = function(ans, nm) { + if (length(nm) > 0L) setattr(ans, "names", nm) + ans +} + as.IDate.default = function(x, ..., tz = attr(x, "tzone", exact=TRUE)) { if (is.null(tz)) tz = "UTC" if (is.character(x)) { @@ -16,31 +21,34 @@ as.IDate.default = function(x, ..., tz = attr(x, "tzone", exact=TRUE)) { as.IDate.numeric = function(x, origin = "1970-01-01", ...) { if (origin=="1970-01-01") { - # standard epoch + nm = names(x) x = as.integer(x) class(x) = c("IDate", "Date") # We used to use structure() here because class(x)<- copied several times in R before v3.1.0 # Since R 3.1.0 improved class()<- and data.table's oldest oldest supported R is now 3.1.0, we can use class<- again # structure() contains a match() and replace for specials, which we don't need. # class()<- ensures at least 1 shallow copy as appropriate is returned. - x + copy_names(x, nm) } else { - # only call expensive as.IDate.character if we have to - as.IDate(origin, ...) + as.integer(x) + as.IDate(origin, ...) + copy_names(as.integer(x), names(x)) } } as.IDate.Date = function(x, ...) { + nm = names(x) x = as.integer(x) # if already integer, x will be left unchanged as the original input class(x) = c("IDate", "Date") # class()<- will copy if as.integer() did not create, and may not if it did we hope - x # always return a new object + copy_names(x, nm) # always return a new object } as.IDate.POSIXct = function(x, tz = attr(x, "tzone", exact=TRUE), ...) { - if (is_utc(tz)) - (setattr(as.integer(as.numeric(x) %/% 86400L), "class", c("IDate", "Date"))) # %/% returns new object so can use setattr() on it; wrap with () to return visibly - else + if (is_utc(tz)) { + ans = as.integer(as.numeric(x) %/% 86400L) + setattr(ans, "class", c("IDate", "Date")) + copy_names(ans, names(x)) + } else { as.IDate(as.Date(x, tz = tz %||% '', ...)) + } } as.IDate.IDate = function(x, ...) x @@ -91,6 +99,8 @@ round.IDate = function(x, digits=c("weeks", "months", "quarters", "years"), ...) years = ISOdate(year(x), 1L, 1L))) } +chooseOpsMethod.IDate = function(x, y, mx, my, cl, reverse) inherits(y, "Date") + #Adapted from `+.Date` `+.IDate` = function(e1, e2) { if (nargs() == 1L) @@ -104,7 +114,11 @@ round.IDate = function(x, digits=c("weeks", "months", "quarters", "years"), ...) } if (inherits(e1, "Date") && inherits(e2, "Date")) stopf("binary + is not defined for \"IDate\" objects") - (setattr(as.integer(unclass(e1) + unclass(e2)), "class", c("IDate", "Date"))) # () wrap to return visibly + res = unclass(e1) + unclass(e2) + nm = names(res) + ans = as.integer(res) + setattr(ans, "class", c("IDate", "Date")) + copy_names(ans, nm) } `-.IDate` = function(e1, e2) { @@ -115,20 +129,25 @@ round.IDate = function(x, digits=c("weeks", "months", "quarters", "years"), ...) if (storage.mode(e1) != "integer") internal_error("storage mode of IDate is somehow no longer integer") # nocov if (nargs() == 1L) - stopf("unary - is not defined for \"IDate\" objects") + stopf('unary - is not defined for "IDate" objects') if (inherits(e2, "difftime")) internal_error("difftime objects may not be subtracted from IDate, but Ops dispatch should have intervened to prevent this") # nocov if ( is.double(e2) && !fitsInInt32(e2) ) { # IDate deliberately doesn't support fractional days so revert to base Date return(base::`-.Date`(as.Date(e1), e2)) - # can't call base::.Date directly (last line of base::`-.Date`) as tried in PR#3168 because - # i) ?.Date states "Internal objects in the base package most of which are only user-visible because of the special nature of the base namespace." - # ii) .Date was newly exposed in R some time after 3.4.4 + # can't call base::.Date directly (last line of base::`-.Date`) as tried in PR#3168 because ?.Date states "Internal objects in the base package most of which are only user-visible because of the special nature of the base namespace." } - ans = as.integer(unclass(e1) - unclass(e2)) - if (!inherits(e2, "Date")) setattr(ans, "class", c("IDate", "Date")) - ans + res = unclass(e1) - unclass(e2) + nm = names(res) + ans = as.integer(res) + if (inherits(e2, "Date")) { + setattr(ans, "class", "difftime") + setattr(ans, "units", "days") + } else { + setattr(ans, "class", c("IDate", "Date")) + } + copy_names(ans, nm) } @@ -150,44 +169,57 @@ as.ITime.POSIXct = function(x, tz = attr(x, "tzone", exact=TRUE), ...) { } as.ITime.numeric = function(x, ms = 'truncate', ...) { + nm = names(x) secs = clip_msec(x, ms) %% 86400L # the %% here ensures a local copy is obtained; the truncate as.integer() may not copy - (setattr(secs, "class", "ITime")) + setattr(secs, "class", "ITime") + copy_names(secs, nm) } as.ITime.character = function(x, format, ...) { + nm = names(x) x = unclass(x) - if (!missing(format)) return(as.ITime(strptime(x, format = format, ...), ...)) - # else allow for mixed formats, such as test 1189 where seconds are caught despite varying format - y = strptime(x, format = "%H:%M:%OS", ...) - w = which(is.na(y)) - formats = c("%H:%M", - "%Y-%m-%d %H:%M:%OS", - "%Y/%m/%d %H:%M:%OS", - "%Y-%m-%d %H:%M", - "%Y/%m/%d %H:%M", - "%Y-%m-%d", - "%Y/%m/%d") - for (f in formats) { - if (!length(w)) break - new = strptime(x[w], format = f, ...) - nna = !is.na(new) - if (any(nna)) { - y[ w[nna] ] = new[nna] - w = w[!nna] + if (!missing(format)) { + ans = as.ITime(strptime(x, format = format, ...), ...) + copy_names(ans, nm) + } else { + # else allow for mixed formats, such as test 1189 where seconds are caught despite varying format + y = strptime(x, format = "%H:%M:%OS", ...) + w = which(is.na(y)) + formats = c("%H:%M", + "%Y-%m-%d %H:%M:%OS", + "%Y/%m/%d %H:%M:%OS", + "%Y-%m-%d %H:%M", + "%Y/%m/%d %H:%M", + "%Y-%m-%d", + "%Y/%m/%d") + for (f in formats) { + if (!length(w)) break + new = strptime(x[w], format = f, ...) + nna = !is.na(new) + if (any(nna)) { + y[ w[nna] ] = new[nna] + w = w[!nna] + } } + ans = as.ITime(y, ...) + copy_names(ans, nm) } - as.ITime(y, ...) } as.ITime.POSIXlt = function(x, ms = 'truncate', ...) { + nm = names(x) secs = clip_msec(x$sec, ms) - (setattr(with(x, secs + min * 60L + hour * 3600L), "class", "ITime")) # () wrap to return visibly + ans = with(x, secs + min * 60L + hour * 3600L) + setattr(ans, "class", "ITime") + copy_names(ans, nm) } as.ITime.times = function(x, ms = 'truncate', ...) { + nm = names(x) secs = 86400L * (unclass(x) %% 1L) secs = clip_msec(secs, ms) - (setattr(secs, "class", "ITime")) # the first line that creates sec will create a local copy so we can use setattr() to avoid potential copy of class()<- + setattr(secs, "class", "ITime") # the first line that creates sec will create a local copy so we can use setattr() to avoid potential copy of class()<- + copy_names(secs, nm) } as.character.ITime = format.ITime = function(x, ...) { @@ -206,7 +238,7 @@ as.character.ITime = format.ITime = function(x, ...) { if (is.na(any(neg))) res[is.na(x)] = NA neg = which(neg) if (length(neg)) res[neg] = paste0("-", res[neg]) - res + copy_names(res, names(x)) } as.data.frame.ITime = function(x, ..., optional=FALSE) { @@ -355,13 +387,35 @@ isoweek = function(x) as.integer(format(as.IDate(x), "%V")) # nearest_thurs = as.IDate(7L * (as.integer(x + 3L) %/% 7L)) # year_start = as.IDate(format(nearest_thurs, '%Y-01-01')) # 1L + (nearest_thurs - year_start) %/% 7L - +isoyear = function(x) as.integer(format(as.IDate(x), "%G")) month = function(x) convertDate(as.IDate(x), "month") quarter = function(x) convertDate(as.IDate(x), "quarter") year = function(x) convertDate(as.IDate(x), "year") -yearmon = function(x) convertDate(as.IDate(x), "yearmon") -yearqtr = function(x) convertDate(as.IDate(x), "yearqtr") +yearmon = function(x, format = c("numeric", "character")) { + format = match.arg(format) + x_as_idate = as.IDate(x) + ymon = convertDate(x_as_idate, "yearmon") + if (format == "numeric") return(ymon) + ans = rep(NA_character_, length(x_as_idate)) + ok = !is.na(x_as_idate) + yr = floor(ymon[ok]) + mon = round((ymon[ok] - yr) * 12) + 1L + ans[ok] = sprintf("%dM%02d", as.integer(yr), as.integer(mon)) + ans +} +yearqtr = function(x, format = c("numeric", "character")) { + format = match.arg(format) + x_as_idate = as.IDate(x) + yqtr = convertDate(x_as_idate, "yearqtr") + if (format == "numeric") return(yqtr) + ans = rep(NA_character_, length(x_as_idate)) + ok = !is.na(x_as_idate) + yr = floor(yqtr[ok]) + qtr = round((yqtr[ok] - yr) * 4) + 1L + ans[ok] = sprintf("%dQ%d", as.integer(yr), as.integer(qtr)) + ans +} convertDate = function(x, type) { type = match.arg(type, c("yday", "wday", "mday", "week", "month", "quarter", "year", "yearmon", "yearqtr")) diff --git a/inst/tests/tests.Rraw b/inst/tests/tests.Rraw index aceeb77f89..b77753ac58 100644 --- a/inst/tests/tests.Rraw +++ b/inst/tests/tests.Rraw @@ -10321,8 +10321,7 @@ test(1673.1, TT + 4L, as.IDate("2016-04-29")) test(1673.2, TT + 4, as.IDate("2016-04-29")) test(1673.3, TT - 3, as.IDate("2016-04-22")) test(1673.4, TT - 3L, as.IDate("2016-04-22")) -test(1673.5, as.IDate("2016-04-28") - as.IDate("2016-04-20"), 8L) - +test(1673.5, as.IDate("2016-04-28") - as.IDate("2016-04-20"), structure(8L, class="difftime", units="days")) # test for radix integer order when MAXINT is present AND decreasing=TRUE AND na.last=FALSE # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=16925 @@ -21426,3 +21425,17 @@ test(2330.7, as.data.table(list(z), keep.rownames=TRUE), data.table(rn=rep("", 3 M <- matrix(1:6, nrow=3, dimnames=list(rep("", 3), c("V1", "V2"))) # test of list(M) for empty-rowname'd matrix input test(2330.8, as.data.table(list(M), keep.rownames=TRUE), data.table(rn=rep("", 3), V1=1:3, V2=4:6)) + +# #7252 as.IDate()/as.ITime preserve names and are compliant with as.Date() +test(2331.01, as.IDate(c(a = "2019-01-01")), as.IDate(as.Date(c(a = "2019-01-01")))) +test(2331.02, c(a = as.IDate("2019-01-01")), structure(as.IDate("2019-01-01"), names="a")) +test(2331.03, as.ITime(c(a = "12:00:00")), structure(as.ITime("12:00:00"), names="a")) +test(2331.04, as.IDate(structure(as.POSIXct("2019-01-01 12:00:00", tz="UTC"), names = "a")), as.IDate(as.Date(structure(as.POSIXct("2019-01-01 12:00:00", tz="UTC"), names = "a")))) +test(2331.05, as.ITime(structure(3600, names = "a")), structure(as.ITime(3600), names="a")) +test(2331.06, as.IDate(c(a = 18000)), as.IDate(as.Date(c(a = 18000), origin="1970-01-01"))) +test(2331.07, as.IDate(c(a = 1), origin = "2020-01-01"), as.IDate(as.Date(c(a = 1), origin = "2020-01-01"))) +test(2331.08, as.ITime(c(a = "12-00-00"), format = "%H-%M-%S"), structure(as.ITime("12:00:00"), names="a")) +test(2331.09, as.IDate(as.POSIXct(c(a = "2019-01-01"), tz="UTC")), as.IDate(as.Date(as.POSIXct(c(a = "2019-01-01"), tz="UTC")))) +test(2331.10, as.IDate(as.POSIXct(c(a = "2019-01-01"), tz="America/New_York")), as.IDate(as.Date(as.POSIXct(c(a = "2019-01-01"), tz="America/New_York")))) +test(2331.11, as.IDate(c(a = 1), origin = c(b = "2020-01-01")), as.IDate(as.Date(c(a = 1), origin = c(b = "2020-01-01")))) +test(2331.12, as.IDate(c(a = 20.5), origin = "2020-01-01"), structure(as.IDate("2020-01-21"), names="a"))