# FHE 13 Jan 2017

# Modified from Hadley Wickham's "lubridate" library

# Extends "floor_date" with fractional units, e.g. "0.1 seconds", or
# "2 milliseconds" (=="2ms")

# Note that we can't get exact rounding due to floating point
# resolution limitations:

## sprintf("%.09f",as.numeric(floor_date(Sys.time(), "ms")))
## [1] "1484369763.108000040"

# However, multiple nearby values should "floor" to the same result:

## > t=Sys.time(); table(sprintf("%.09f",as.numeric(floor_date(c(t,t+1e-4,t+2e-4), "ms"))))
## 1484369576.492000103
## 3

# Currently only works for "seconds", modify trunc_multi_unit if you
# want to be able to specify "0.25 hour" etc.

# TODO: add round_date, ceiling_date

floor_date <- function(x, unit = "seconds") {
  if(!length(x)) return(x)

  parsed_unit <- parse_period_unit(unit)
  n <- parsed_unit$n
  unit <- standardise_period_names(parsed_unit$unit)

  if(unit %in% c("microsecond", "millisecond")){
    switch(unit,
           microsecond = n <- n/1e6,
           millisecond = n <- n/1e3,
           )
    unit <- "second"
  }

  if(unit %in% c("second", "minute", "hour", "day")){

    out <- trunc_multi_unit(x, unit, n)
    reclass_date_maybe(out, x, unit)

  } else {

    if(n > 1 && unit == "week"){
      ## fixme:
      warning("Multi-unit not supported for weeks. Ignoring.")
    }

    if(unit %in% c("bimonth", "quarter", "halfyear")){
      switch(unit,
             bimonth = n <- 2 * n,
             quarter = n <- 3 * n,
             halfyear = n <- 6 * n)
      unit <- "month"
    }

    switch(unit,
           week     = update(x, wdays = 1, hours = 0, minutes = 0, seconds = 0),
           month    = {
             if(n > 1)
               update(x, months = floor_multi_unit1(month(x), n), mdays = 1, hours = 0, minutes = 0, seconds = 0)
             else
               update(x, mdays = 1, hours = 0, minutes = 0, seconds = 0)
           },
           year     = {
             ## due to bug https://github.com/hadley/lubridate/issues/319 we
             ## need to do it in two steps
             if(n > 1){
               y <- update(x, ydays = 1, hours = 0, minutes = 0, seconds = 0)
               update(y, years = floor_multi_unit(year(y), n))
             } else {
               update(x, ydays = 1, hours = 0, minutes = 0, seconds = 0)
             }
           })
  }
}

parse_period_unit <- function(unit) {

  if (length(unit) > 1) {
    warning("Unit argument longer than 1. Taking first element.")
    unit <- unit[[1]]
  }

  # FHE 13 Jan 2017
  # Elide the C code since we also have an R implementation
#  p <- .Call("c_parse_period", as.character(unit))
  p=list(NA);

  if (!is.na(p[[1]])) {

    period_units <- c("second", "minute", "hour", "day", "week", "month", "year")

    wp <- which(p > 0)
    if(length(wp) > 1){
      stop("Multi unit periods are not yet supported")
    }

    list(n = p[wp], unit = period_units[wp])

  } else {

    ## this is for backward compatibility and allows for bimonth, halfyear and quarter
    m <- regexpr(" *(?<n>[0-9.,]+)? *(?<unit>[^ \t\n]+)", unit[[1]], perl = T)
    if(m > 0){
      ## should always match
      nms <- attr(m, "capture.names")
      nms <- nms[nzchar(nms)]
      start <- attr(m, "capture.start")
      end <- start + attr(m, "capture.length") - 1L
      n <- if(end[[1]] >= start[[1]]){
             as.numeric(str_sub(unit, start[[1]], end[[1]]))
           } else {
             1
           }
      unit <- str_sub(unit, start[[2]], end[[2]])
      list(n = n, unit = unit)
    } else {
      stop(sprintf("Invalid unit specification '%s'", unit))
    }

  }
}

trunc_multi_unit <- function(x, unit, n){
  y <- as.POSIXlt(x)
  switch(unit,
         second = {
           y$sec <- if(n == 1) trunc(y$sec) else floor_multi_unit(y$sec, n)
         },
         minute = {
           y$sec[] <- 0
           y$min <- floor_multi_unit(y$min, n)
         },
         hour = {
           y$sec[] <- 0
           y$min[] <- 0L
           y$hour <- floor_multi_unit(y$hour, n)
         },
         day = {
           y$sec[] <- 0
           y$min[] <- 0L
           y$hour[] <- 0L
           y$isdst[] <- -1L
           y$mday <- floor_multi_unit1(y$mday, n)
         },
         stop("Invalid unit ", unit))
  y
}

floor_multi_unit <- function(n, len) {
  (n %/% len) * len
}

floor_multi_unit1 <- function(n, len) {
  (((n - 1) %/% len) * len) + 1L
}

standardise_period_names <- function(x) {
  dates <- c("second", "minute", "hour", "day", "week", "month", "year",
             ## these ones are used for rounding only
             "bimonth", "quarter", "halfyear")
  res <- dates[pmatch(substr(x, 1, 3), dates)]
  # could speed this up by only grepping on NA elements of res
  # (but when is this function called with >1 element?)
  res[grep("^(ms|mil)",x)] = "millisecond"
  res[grep("^(us|micro)",x)] = "microsecond"
  if (any(is.na(res))) {
    stop("Invalid period name: ", paste(x[is.na(res)], collapse = ", "),
      call. = FALSE)
  }
  res
}

reclass_date_maybe <- function(new, orig, unit){
  if(is.Date(orig) && !unit %in% c("day", "week", "month", "year")) as.POSIXct(new)
  else reclass_date(new, orig)
}