#' @import R6
NULL

#' @title Basic CF calendar
#'
#' @description This class represents a basic CF calendar. It should not be
#'   instantiated directly; instead, use one of the descendant classes.
#'
#'   This internal class stores the information to represent date and time
#'   values using the CF conventions. An instance is created by the exported
#'   [CFTime] class, which also exposes the relevant properties of this class.
#'
#'   The following calendars are supported:
#'
#' \itemize{
#'   \item [`gregorian\standard`][CFCalendarStandard], the international standard calendar for civil use.
#'   \item [`proleptic_gregorian`][CFCalendarProleptic], the standard calendar but extending before 1582-10-15
#'   when the Gregorian calendar was adopted.
#'   \item [`tai`][CFCalendarTAI], International Atomic Time clock with dates expressed using the Gregorian calendar.
#'   \item [`utc`][CFCalendarUTC], Coordinated Universal Time clock with dates expressed using the Gregorian calendar.
#'   \item [`julian`][CFCalendarJulian], every fourth year is a leap year.
#'   \item [`noleap\365_day`][CFCalendar365], all years have 365 days.
#'   \item [`all_leap\366_day`][CFCalendar366], all years have 366 days.
#'   \item [`360_day`][CFCalendar360], all years have 360 days, divided over 12 months of 30 days.
#' }
#' @references
#'   https://cf-convention.github.io/Data/cf-conventions/cf-conventions-1.13/cf-conventions.html#calendar
#' @docType class
CFCalendar <- R6::R6Class("CFCalendar",
  private = list(
    .name = "",
    .definition = "",
    .unit = -1L,

    # The index into the CFt$prefixes data.frame, if a prefix is being used.
    # Default value of 0L indicates no prefix.
    .prefix = 0L,

    .origin = data.frame(),

    # This method parses the unit to see if it is known, including any prefix
    # for multiples or sub-multiples (section 3.1.3 of the conventions)
    parse_unit = function(x) {
      units <- CFt$CFunits$unit

      # Try exact match - case-insensitive
      u <- which(units == tolower(x))
      if (length(u))
        return(list(prefix = 0L, unit = CFt$CFunits$id[u]))

      # Try prefix + unit combinations - check longest unit names first
      usort <- units[order(nchar(units), decreasing = TRUE)]
      umatch <- which(endsWith(x, usort))
      if (length(umatch)) {
        for (m in 1:length(umatch)) {
          u <- usort[umatch[m]]
          pref <- sub(paste0(u, "$"), "", x)
          pmatch <- match(pref, CFt$prefixes$name)
          if (is.na(pmatch))
            pmatch <- match(pref, CFt$prefixes$abbrev)
          if (!is.na(pmatch))
            return(list(prefix = pmatch, unit = CFt$CFunits$id[match(u, units)]))
        }
      }
      return(list(prefix = 0L, unit = NA))
    }
  ),
  public = list(
    #' @description Create a new CF calendar.
    #' @param nm The name of the calendar. This must follow the CF Metadata
    #' Conventions.
    #' @param definition The string that defines the units and the origin, as
    #' per the CF Metadata Conventions.
    initialize = function(nm, definition) {
      stopifnot(length(definition) ==  1L, length(nm) == 1L)
      private$.name <- tolower(nm)
      private$.definition <- definition

      parts <- strsplit(definition, " ")[[1L]]
      if ((length(parts) < 3L) || !(tolower(parts[2L]) %in% c("since", "after", "from", "ref", "per")))
        stop("Definition string does not appear to be a CF-compliant time coordinate description", call. = FALSE)
      u <- private$parse_unit(parts[1L])
      if (is.na(u$unit)) stop("Unsupported unit: ", parts[1L], call. = FALSE)
      private$.unit <- u$unit
      private$.prefix <- u$prefix

      dt <- self$parse(paste(parts[3L:length(parts)], collapse = " "))
      if (is.na(dt$year[1L]))
        stop("Definition string does not appear to be a CF-compliant time coordinate description: invalid base date specification", call. = FALSE)
      private$.origin <- dt
    },

    #' @description Print information about the calendar to the console.
    #' @param ... Ignored.
    #' @return `self`, invisibly.
    print = function(...) {
      tz <- self$timezone
      if (tz == "+0000") tz <- ""
      cat("CF calendar:",
          "\n  Origin  : ", self$origin_date, "T", self$origin_time, tz,
          "\n  Units   : ", paste0(if (private$.prefix) CFt$prefixes$name[private$.prefix], CFt$units$name[private$.unit]),
          "\n  Type    : ", private$.name, "\n",
          sep = "")
      invisible(self)
    },

    #' @description Indicate which of the supplied dates are valid.
    #' @param ymd `data.frame` with dates parsed into their parts in columns
    #'   `year`, `month` and `day`. Any other columns are disregarded.
    #' @return `NULL`. A warning will be generated to the effect that a
    #' descendant class should be used for this method.
    valid_days = function(ymd) {
      warning("Use a descendant class from `CFCalendar` to call this method.", call. = FALSE) # nocov
      NULL                                                                                    # nocov
    },

    #' @description Add a day to the supplied dates.
    #' @param ymd `data.frame` with dates parsed into their parts in columns
    #'   `year`, `month` and `day`. Any other columns are disregarded.
    #' @return A `data.frame` like argument `ymd` but with a day added for every
    #'   row.
    add_day = function(ymd) {
      md <- self$month_days(ymd)
      ifelse(ymd$day < md,
             ymd$day <- ymd$day + 1L,
             {
               ymd$day <- 1L
               ifelse(ymd$month < 12L,
                      ymd$month <- ymd$month + 1L,
                      {
                        ymd$month <- 1L
                        ymd$year <- ymd$year + 1L
                      }
               )
             }
      )
      ymd
    },

    #' @description Indicate if the time series described using this calendar
    #'   can be safely converted to a standard date-time type (`POSIXct`,
    #'   `POSIXlt`, `Date`).
    #'
    #'   Only the 'standard' calendar and the 'proleptic_gregorian' calendar
    #'   when all dates in the time series are more recent than 1582-10-15
    #'   (inclusive) can be safely converted, so this method returns `FALSE` by
    #'   default to cover the majority of cases.
    #' @param offsets The offsets from the CFtime instance.
    #' @return `FALSE` by default.
    POSIX_compatible = function(offsets) {
      FALSE
    },

    #' @description This method tests if the `CFCalendar` instance in argument
    #'   `cal` is compatible with `self`, meaning that they are of the same
    #'   class and have the same unit and prefix. Calendars "standard", and
    #'   "gregorian" are compatible, as are the pairs of "365_day" and
    #'   "no_leap", and "366_day" and "all_leap".
    #' @param cal Instance of a descendant of the `CFCalendar` class.
    #' @return `TRUE` if the instance in argument `cal` is compatible with
    #'   `self`, `FALSE` otherwise.
    is_compatible = function(cal) {
      private$.unit == cal$unit && private$.prefix == cal$prefix_id &&
      class(self)[1L] == class(cal)[1L]
    },

    #' @description This method tests if the `CFCalendar` instance in argument
    #'   `cal` is equivalent to `self`, meaning that they are of the same class,
    #'   have the same unit and prefix, and equivalent origins. Calendars
    #'   "standard", and "gregorian" are equivalent, as are the pairs of
    #'   "365_day" and "no_leap", and "366_day" and "all_leap".
    #'
    #'   Note that the origins need not be identical, but their parsed values
    #'   have to be. "2000-01" is parsed the same as "2000-01-01 00:00:00", for
    #'   instance.
    #' @param cal Instance of a descendant of the `CFCalendar` class.
    #' @return `TRUE` if the instance in argument `cal` is equivalent to `self`,
    #'   `FALSE` otherwise.
    is_equivalent = function(cal) {
      all(private$.origin[1L,1L:6L] == cal$origin[1L,1L:6L]) &&  # Offset column is NA
      self$is_compatible(cal)
    },

    #' @description Parsing a vector of date-time character strings into parts.
    #' @param d character. A character vector of date-times.
    #' @return A `data.frame` with columns year, month, day, hour, minute,
    #'   second, time zone, and offset. Invalid input data will appear as `NA`.
    parse = function(d) {
      # Parsers

      # UDUNITS broken timestamp definition, with some changes
      # broken_timestamp	{broken_date}({space|T}+{broken_clock})? -- T not in definition but present in lexer code
      # broken_date		    {year}-{month}(-{day})?
      # year		        	[+-]?[0-9]{1,4}
      # month			        0?[1-9]|1[0-2]
      # day			          0?[1-9]|[1-2][0-9]|30|31
      # broken_clock		  {hour}:{minute}(:{second})?
      # hour			        [0-1]?[0-9]|2[0-3]      -- sign on hour not allowed, but see timezone
      # minute			      [0-5]?[0-9]
      # second		      	{minute}?               -- leap second not supported
      # fractional part   (\.[0-9]*)?
      # timezone          [+-]?{hour}(:{minute})? -- added, present in lexer code
      broken <- paste0(
        "^",                                    # anchor string at start
        "([+-]?[0-9]{1,4})",                    # year, with optional sign
        "-(0?[1-9]|1[012])",                    # month
        "(?:-(0?[1-9]|[12][0-9]|3[01]))?",      # day, optional
        "(?:[T ]",                              # if a time is following, separate with a single whitespace character or a "T"
        "([01]?[0-9]|2[0-3])",                  # hour
        ":([0-5]?[0-9])",                       # minute
        "(?::([0-5]?[0-9]))?",                  # second, optional
        "(?:\\.([0-9]*))?",                     # optional fractional part of the smallest specified unit
        ")?",                                   # close optional time capture group
        "(?:\\s",                               # if a time zone offset is following, separate with a single whitespace character
        "([+-])?([01]?[0-9]|2[0-3])",           # tz hour, with optional sign
        "(?::(00|15|30|45))?",                  # optional tz minute, only 4 possible values
        ")?",                                   # close optional timezone capture group
        "$"                                     # anchor string at end
      )

      iso8601 <- paste0(
        "^",
        "([0-9]{4})",
        "-(0[1-9]|1[012])",
        "-(0[1-9]|[12][0-9]|3[01])?",
        "(?:",
        "[T ]([01][0-9]|2[0-3])",
        "(?::([0-5][0-9]))?",
        "(?::([0-5][0-9]))?",
        "(?:[\\.,]([0-9]*))?",
        ")?",
        "(?:([Z+-])([01][0-9]|2[0-3])?(?::(00|15|30|45))?", ## FIXME: Z?, smaller number of captures
        ")?$"
      )

      # UDUNITS packed timestamp definition - NOT YET USED
      # packed_timestamp	{packed_date}({space|T}+{packed_clock})?  -- T and space only allowed in packed time follows
      # packed_date	    	{year}({month}{day}?)?           -- must be YYYYMMDD or else format is ambiguous, as per lexer code
      # packed_clock		  {hour}({minute}{second}?)?       -- must be HHMMSS to be unambiguous
      # timezone          [+-]?{hour}({minute})?           -- added, present in lexer code, must be HHMM
      # packed <- stringi::stri_join(
      #   "^",                                    # anchor string at start
      #   "([+-]?[0-9]{4})",                      # year, with optional sign
      #   "(0[1-9]|1[012])?",                     # month, optional
      #   "(0[1-9]|[12][0-9]|3[01])?",            # day, optional
      #   "(?:[T,\\s]",                           # if a time is following, separate with a single whitespace character or a "T"
      #     "([01][0-9]|2[0-3])?",                # hour
      #     "([0-5][0-9])?",                      # minute, optional
      #     "([0-5]?[0-9](?:\\.[0-9]*)?)?",       # second, optional, with optional fractional part
      #   ")?",                                   # close optional time capture group
      #   "(?:\\s",                               # if a time zone offset is following, separate with a single whitespace character
      #     "([+-]?[01][0-9]|2[0-3])?",           # hour, with optional sign
      #     "(00|15|30|45)?",                     # minute, only 4 possible values
      #   ")?",                                   # close optional timezone capture group
      #   "$"                                     # anchor string at end
      # )

      parse <- data.frame(year = integer(), month = integer(), day = integer(),
                          hour = integer(), minute = integer(), second = numeric(), frac = character(),
                          tz_sign = character(), tz_hour = character(), tz_min = character())

      # Drop "UTC", if given
      d <- trimws(gsub("UTC$", "", d))

      cap <- utils::strcapture(iso8601, d, parse)
      missing <- which(is.na(cap$year))
      if (length(missing) > 0L)
        cap[missing,] <- utils::strcapture(broken, d[missing], parse)

      # Assign any fraction to the appropriate time part
      cap$frac[is.na(cap$frac)] <- "0"
      frac <- as.numeric(paste0("0.", cap$frac))
      if (sum(frac) > 0) {
        ndx <- which(!(is.na(cap$second)) & frac > 0)
        if (length(ndx) > 0L) cap$second[ndx] <- cap$second[ndx] + frac[ndx]
        ndx <- which(!(is.na(cap$minute)) & is.na(cap$second) & frac > 0)
        if (length(ndx) > 0L) cap$second[ndx] <- 60L * frac[ndx]
        ndx <- which(!(is.na(cap$hour)) & is.na(cap$minute) & frac > 0)
        if (length(ndx) > 0L) {
          secs <- 3600 * frac
          cap$minute[ndx] <- secs[ndx] %/% 60
          cap$second[ndx] <- secs[ndx] %% 60
        }
      }
      cap$frac <- NULL

      # Convert NA time parts to 0 - in CF default time is 00:00:00 when not specified
      cap$hour[is.na(cap$hour)] <- 0L
      cap$minute[is.na(cap$minute)] <- 0L
      cap$second[is.na(cap$second)] <- 0L

      # Set timezone to default value where needed
      ndx <- which(cap$tz_sign == "Z")
      if (length(ndx) > 0L) {
        cap$tz_sign[ndx] <- "+"
        cap$tz_hour[ndx] <- "00"
        cap$tz_min[ndx] <- "00"
      }
      cap$tz <- paste0(ifelse(cap$tz_sign == "", "+", cap$tz_sign),
                       ifelse(cap$tz_hour == "", "00", cap$tz_hour),
                       ifelse(cap$tz_min == "", "00", cap$tz_min))
      cap$tz <- ifelse(cap$tz =="NANANA", "+0000", cap$tz)
      cap$tz_sign <- cap$tz_hour <- cap$tz_min <- NULL

      # Set optional date parts to 1 if not specified
      cap$month[is.na(cap$month)] <- 1L
      cap$day[is.na(cap$day)] <- 1L

      # Check date validity
      invalid <- !self$valid_days(cap)
      invalid[is.na(invalid)] <- TRUE
      if (sum(invalid) > 0L) cap[invalid,] <- rep(NA, 7)

      # Calculate offsets
      if (nrow(self$origin) == 0L) {        # if there's no origin yet, don't calculate offsets
        cap$offset <- rep(0, nrow(cap))     # this happens, f.i., when a CFCalendar is created
      } else {
        days <- self$date2offset(cap)
        pref <- if (private$.prefix) CFt$prefixes$multiplier[private$.prefix] else 1
        cap$offset <- round((days * 86400 + (cap$hour - private$.origin$hour[1]) * 3600 +
                             (cap$minute - private$.origin$minute[1]) * 60 +
                             cap$second - private$.origin$second) /
                             (CFt$units$seconds[private$.unit] * pref), 6)
      }
      cap
    },

    #' @description Retrieve the day-of-year number for the supplied
    #'   `data.frame` of year, month and day, using this calendar. This method
    #'   tests for leap years - calendars without leap years may override this
    #'   method for efficiency.
    #' @param ymd `data.frame` with dates parsed into their parts in columns
    #'   `year`, `month` and `day`. Any other columns are disregarded.
    #' @return Integer vector as long as argument `ymd` has rows with the
    #'   day-of-year for each row.
    doy = function(ymd) {
      cum_month <- c(0L, 31L, 59L, 90L, 120L, 151L, 181L, 212L, 243L, 273L, 304L, 334L) # days in year before the month
      doy <- cum_month[ymd$month] + ymd$day
      doy <- ifelse(self$leap_year(ymd$year) & ymd$month > 2L, doy + 1L, doy)
      doy
    },

    #' @description Decompose a vector of offsets, in units of the calendar, to
    #'   their timestamp values. This adds a specified amount of time to the
    #'   origin of a `CFTime` object.
    #'
    #'   This method may introduce inaccuracies where the calendar unit is
    #'   "months" or "years", due to the ambiguous definition of these units.
    #' @param offsets Vector of numeric offsets to add to the origin of the
    #'   calendar.
    #' @return A `data.frame` with columns for the timestamp elements and as
    #'   many rows as there are offsets.
    offsets2time = function(offsets = NULL) {
      if(is.null(offsets) || (len <- length(offsets)) == 0L)
        return(data.frame(year = integer(), month = integer(), day = integer(),
                          hour = integer(), minute = integer(), second = numeric(),
                          tz = character(), offset = numeric()))

      prefix <- if (private$.prefix) CFt$prefixes$multiplier[private$.prefix] else 1

      if (private$.unit <= 4L) { # Days, hours, minutes, seconds
        # First add time: convert to seconds first, then recompute time parts
        secs <- offsets * CFt$units$seconds[private$.unit] * prefix +
                private$.origin$hour * 3600 + private$.origin$minute * 60 + private$.origin$second
        days <- secs %/% 86400L            # overflow days
        secs <- round(secs %% 86400L, 3L)  # drop overflow days from time, round down to milli-seconds to avoid errors

        # Time elements for output
        hrs <- secs %/% 3600L
        mins <- (secs %% 3600L) %/% 60L
        secs <- secs %% 60L

        # Now add days using the calendar
        out <- if (any(days != 0L))
          self$offset2date(days)
        else
          data.frame(year = rep(private$.origin$year, len),
                     month = rep(private$.origin$month, len),
                     day = rep(private$.origin$day, len))

        # Put it all back together again
        out$hour <- hrs
        out$minute <- mins
        out$second <- secs
        out$tz <- rep(self$timezone, len)
      } else { # Months, years
        out <- private$.origin[rep(1L, len), ]
        if (private$.unit == 5L) { # Offsets are months
          months <- out$month + offsets * prefix - 1L
          out$month <- months %% 12L + 1L
          out$year <- out$year + months %/% 12L
        } else {               # Offsets are years
          out$year <- out$year + offsets * prefix
        }
      }
      out$offset <- offsets
      out
    }

  ),
  active = list(
    #' @field name (read-only) Name of the calendar, as per the CF Metadata
    #'   Conventions.
    name = function(value) {
      if (missing(value))
        private$.name
    },

    #' @field definition (read-only) The string that defines the units and the
    #'   origin, as per the CF Metadata Conventions.
    definition = function(value) {
      if (missing(value))
        private$.definition
    },

    #' @field unit (read-only) The numeric id of the unit of the calendar.
    unit = function(value) {
      if (missing(value))
        private$.unit
    },

    #' @field prefix_id (read-only) The index value of the prefix of the time
    #' unit. If the unit does not have a prefix, returns the value 0L.
    prefix_id = function(value) {
      if (missing(value))
        private$.prefix
    },

    #' @field origin (read-only) `data.frame` with fields for the origin of the
    #'   calendar.
    origin = function(value) {
      if (missing(value))
        private$.origin
    },

    #' @field origin_date (read-only) Character string with the date of the
    #'   calendar.
    origin_date = function(value) {
      if (missing(value)) {
        sprintf("%04d-%02d-%02d", self$origin$year, self$origin$month, self$origin$day)
      }
    },

    #' @field origin_time (read-only) Character string with the time of the
    #'   calendar.
    origin_time = function(value) {
      if (missing(value)) {
        .format_time(self$origin)
      }
    },

    #' @field timezone (read-only) Character string with the time zone of the
    #' origin of the calendar.
    timezone = function(value) {
      if (missing(value))
        self$origin$tz
    }
  )
)
