moved all the new helper functions required for generating breaks and…

… scales to the appropriate files, added documentation for as_yearqtr, added round, ceiling, floor for all date_xx

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: dint
 Title: A Toolkit for Year-Quarter, Year-Month and Year-Isoweek Dates
-Version: 2.0.0.9000
+Version: 2.0.0.9001
 Authors@R: person("Stefan", "Fleck", email = "[email protected]", role = c("aut", "cre"))
 Maintainer: Stefan Fleck <[email protected]>
 Description: 
@@ -20,6 +20,7 @@ Suggests:
     lubridate,
     rmarkdown,
     testthat,
+    zoo,
     covr
 VignetteBuilder: knitr
 Encoding: UTF-8

NAMESPACE

@@ -44,14 +44,14 @@ S3method(as_date_yq,Date)
 S3method(as_date_yq,date_yq)
 S3method(as_date_yq,default)
 S3method(as_date_yq,numeric)
+S3method(as_date_yq,yearqtr)
 S3method(as_date_yw,Date)
 S3method(as_date_yw,date_yw)
 S3method(as_date_yw,default)
 S3method(as_date_yw,numeric)
-S3method(as_yeartqtr,date_yq)
-S3method(as_yeartqtr,yearqtr)
+S3method(as_yearqtr,date_yq)
 S3method(c,date_xx)
-S3method(ceiling,date_yq)
+S3method(ceiling,date_xx)
 S3method(first_of_isoweek,default)
 S3method(first_of_isoyear,date_yw)
 S3method(first_of_isoyear,default)
@@ -62,7 +62,7 @@ S3method(first_of_quarter,default)
 S3method(first_of_year,default)
 S3method(first_of_year,integer)
 S3method(first_of_year,numeric)
-S3method(floor,date_yq)
+S3method(floor,date_xx)
 S3method(format,date_y)
 S3method(format,date_ym)
 S3method(format,date_yq)
@@ -94,7 +94,9 @@ S3method(last_of_year,default)
 S3method(last_of_year,integer)
 S3method(last_of_year,numeric)
 S3method(print,date_xx)
+S3method(round,date_ym)
 S3method(round,date_yq)
+S3method(round,date_yw)
 S3method(seq,date_ym)
 S3method(seq,date_yq)
 S3method(seq,date_yw)
@@ -110,7 +112,7 @@ export(as_date_y)
 export(as_date_ym)
 export(as_date_yq)
 export(as_date_yw)
-export(as_yeartqtr)
+export(as_yearqtr)
 export(date_y)
 export(date_ym)
 export(date_yq)
@@ -162,4 +164,3 @@ export(make_date_xx)
 export(scale_date_yq)
 export(scale_x_date_yq)
 export(scale_y_date_yq)
-export(yearqtr)

R/arithmetic.R

@@ -177,50 +177,70 @@ range.date_y <- function(..., na.rm = FALSE) {
 
 # round -------------------------------------------------------------------
 
-#' Title
+#' Rounding of date_xx
 #'
-#' @param x
+#' Rounds a `date_xx` to the first unit of the current year, or the first
+#' unit of the next year.
 #'
-#' @return
+#' @param x any `date_xx` object
+#' @param digits ignored, only there for compat with [base::round()]
+#'
+#' @return a `date_xx` of the same subclass as `x`
 #' @export
 #'
 #' @examples
-ceiling.date_yq <- function(x){
-  date_yq(get_year(x) + 1L, 1L)
+#'
+#' round(date_yq(2018, 2))
+#' round(date_yq(2018, 3))
+#' round(date_ym(2018, 6))
+#' round(date_ym(2018, 7))
+#' round(date_yw(2018, 26))
+#' round(date_yw(2018, 27))
+#'
+round.date_yq <- function(x, digits = NULL){
+  q <- get_quarter(x)
+  ifelse_simple(q %in% 1:2, floor(x), ceiling(x))
 }
 
 
 
+#' @rdname round
+#' @export
+round.date_ym <- function(x, digits = NULL){
+  q <- get_month(x)
+  ifelse_simple(q %in% 1:6, floor(x), ceiling(x))
+}
 
-#' Title
-#'
-#' @param x
-#'
-#' @return
+
+#' @rdname round
 #' @export
-#'
-#' @examples
-floor.date_yq <- function(x){
-  date_yq(get_year(x), 1L)
+round.date_yw <- function(x, digits = NULL){
+  q <- get_isoweek(x)
+  ifelse_simple(q %in% 1:26, floor(x), ceiling(x))
+}
+
+
+
+#' @rdname round
+#' @export
+ceiling.date_xx <- function(x){
+  do.call(which_date_xx(x), list(get_year(x) + 1L, 1L))
 }
 
 
 
 
-#' Title
-#'
-#' @param x
-#'
-#' @return
+#' @rdname round
 #' @export
-#'
-#' @examples
-round.date_yq <- function(x){
-  q <- get_quarter(x)
-  ifelse_simple(q %in% 1:2, floor(x), ceiling(x))
+floor.date_xx <- function(x){
+  do.call(which_date_xx(x), list(get_year(x), 1L))
 }
 
 
+
+
+
+
 # generics ----------------------------------------------------------------
 
 #' Add/Subtract Year

R/date_xx_scale.R

@@ -55,97 +55,41 @@ scale_date_yq <- function(
 #'
 #' @examples
 date_yq_breaks <- function(
-  x
+  x,
+  each = NULL
 ){
-    x <- as_date_yq(x)
+  force(each)
 
-    xmin <- min(x)
-    xmax <- max(x)
+  function(x){
+    if (is.null(each)){
+      x <- as_date_yq(x)
 
-    nyears <- get_year(xmax) - get_year(xmin)
+      xmin <- min(x)
+      xmax <- max(x)
 
-    if (nyears <= 2L){
-      return(seq(xmin + 1L, xmax- 1L))
-    }
-    else if (nyears == 3){
-      xmin <- xmin + 1L
-      xmax <- xmax - 1L
-      if (get_quarter(xmin) %in%  c(2, 4))  xmin <- xmin + 1L
-
-      return(seq(xmin, xmax, by = 2))
-
-    } else {
+      nyears <- get_year(xmax) - get_year(xmin)
 
-      if (get_quarter(xmax) == 1L) xmax <- xmax - 1L
-
-      each <- round((get_year(xmax) - get_year(xmin)) / 6)
-      seq(ceiling(xmin), floor(xmax), by = 4 * each)
-    }
-}
+      if (nyears <= 2L){
+        return(seq(xmin + 1L, xmax- 1L))
+      }
+      else if (nyears == 3){
+        xmin <- xmin + 1L
+        xmax <- xmax - 1L
+        if (get_quarter(xmin) %in%  c(2, 4))  xmin <- xmin + 1L
 
+        return(seq(xmin, xmax, by = 2))
 
+      } else {
 
-as_date_yq.yearqtr <- function(
-  x
-){
-  x <- as.numeric(x)
-  assert(all(x > 0 | is.na(x)))
-
-  tx  <- trunc(x)
-  rem <- x - tx
-
-  assert(all(rem %in% c(0, 0.25, 0.5, 0.75)))
-
-  date_yq(tx,  (x - tx) * 4 + 1L )
-}
-
+        if (get_quarter(xmax) == 1L) xmax <- xmax - 1L
 
-#' Title
-#'
-#' @param x
-#'
-#' @return
-#' @export
-#'
-#' @examples
-as_yeartqtr <- function(x){
-  UseMethod("as_yeartqtr")
-}
-
-#' Title
-#'
-#' @param x
-#'
-#' @return
-#' @export
-#'
-#' @examples
-yearqtr <- function(x){
-  structure(x, class = c("yearqtr", "numeric"))
+        each <- round((get_year(xmax) - get_year(xmin)) / 6)
+        seq(ceiling(xmin), floor(xmax), by = 4 * each)
+      }
+    } else {
+      stop("not yet supported")
+    }
+  }
 }
 
 
-
-#' Title
-#'
-#' @param x
-#'
-#' @return
-#' @export
-#'
-#' @examples
-as_yeartqtr.date_yq <- function(x){
-  yearqtr(get_year(x) + (get_quarter(x) - 1L) / 4)
-}
-
-#' Title
-#'
-#' @param x
-#'
-#' @return
-#' @export
-#'
-#' @examples
-as_yeartqtr.yearqtr <- function(x){
-  x
-}

R/date_yq.R

@@ -77,6 +77,20 @@ as_date_yq.default <- function(x){
 
 
 
+#' @export
+as_date_yq.yearqtr <- function(
+  x
+){
+  x <- as.numeric(x)
+  assert(all(x > 0 | is.na(x)))
+  tx  <- trunc(x)
+  rem <- x - tx
+  assert(all(rem %in% c(0, 0.25, 0.5, 0.75)))
+  date_yq(tx,  (x - tx) * 4 + 1L )
+}
+
+
+
 
 #' @export
 as_date_yq.numeric <- function(x){

R/dint-package.R

@@ -6,5 +6,6 @@
 .onLoad <- function(...) {
   dyn_register_s3_method("lubridate", "year", "date_xx")
   dyn_register_s3_method("lubridate", "month", "date_xx")
+  dyn_register_s3_method("zoo", "as.yearqtr", "date_yq")
   invisible()
 }

R/zoo-yearqtr.R

@@ -0,0 +1,59 @@
+#' For compat with zoo
+#'
+#' Internaly used constructor. If you use zoo, please use [zoo::yearqtr()]
+#' instead
+#'
+#' @param x a vector with dates in the form 2000.0 for Q1, 2000.25 for Q2, usw
+#' @noRd
+#'
+yearqtr <- function(x){
+  assert(all((x %% 1) %in% c(0, 0.25, 0.5, 0.75)))
+  structure(x, class = c("yearqtr", "numeric"))
+}
+
+
+
+
+#' Coerce to zoo yeartqr objects
+#'
+#' `as_yearqtr()` is included for interoperatility with [zoo::yearqtr()],
+#' an alternative year-quarter format that is based on a decimal representation
+#' as opposed to dint's integer representation of year-quarters.
+#'
+#' @param x any \R object
+#'
+#' @return a [zoo::yearqtr] vector
+#' @export
+#'
+#' @examples
+#'
+#' x <- date_yq(2016, 2)
+#' as_yearqtr(x)
+#'
+as_yearqtr <- function(x){
+  UseMethod("as_yearqtr")
+}
+
+
+
+
+#' @rdname as_yearqtr
+#' @export
+as_yearqtr.date_yq <- function(x){
+  yearqtr(get_year(x) + (get_quarter(x) - 1L) / 4)
+}
+
+
+
+#' @rdname as_yearqtr
+as_yearqtr.yearqtr <- function(x){
+  x
+}
+
+
+
+
+# zoo dynamic s3 mehtods --------------------------------------------------
+
+# dynamically registered if zoo is installed
+as.yearqtr.date_yq <- as_yearqtr.date_yq