#  File src/library/grDevices/R/prettyDate.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2023 The R Core Team
#
# Original code Copyright (C) 2010 Felix Andrews
# Modifications Copyright (C) 2010 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

##' S3 method =:  pretty.Date() and pretty.POSIXt [in ../NAMESPACE]
prettyDate <- function(x, n = 5, min.n = n %/% 2, sep = " ", ...)
{
    stopifnot(min.n <= n)
    isDate <- inherits(x, "Date")
    x <- as.POSIXct(x)
    if (isDate) # the timezone *does* matter
	attr(x, "tzone") <- "GMT"
    zz <- rx <- range(x, na.rm = TRUE)
    D <- diff(nzz <- as.numeric(zz))
    MIN <- 60
    HOUR <- MIN * 60
    DAY <- HOUR * 24
    YEAR <- DAY * 365.25
    MONTH <- YEAR / 12
    makeOutput <- function(at, s, round = TRUE, do) {
	structure(if(isDate)
		      if(round) as.Date(round(at, units = "days")) else at
		  else as.POSIXct(at),
		  labels = format(at, s$format),
          format = s$format)
    }
    if(isDate && D <= n * DAY) { # D <= 'n days' & Date  ==> use days
	zz <- as.Date(zz)
	r <- round(n - D/DAY)
	m <- max(0, r %/% 2)
        m2 <- m + (r %% 2)
	while(length(dd <- seq.Date(zz[1] - m, zz[2] + m2, by = "1 day")) < min.n + 1)
	    if(m < m2) m <- m+1 else m2 <- m2+1
	return(makeOutput(dd, round = FALSE, ## "1 DSTday" from steps:
			  list(format = paste("%b", "%d", sep = sep))))
    }
    else if(D < 1) { # unique values / sub-second ranges: [? or use "1 ms" steps below?]
	m <- min(30, max(D == 0, n/2))
	zz <- structure(c(floor(nzz[1] - m), ceiling(nzz[2] + m)),
			class = class(x), tzone = attr(x, "tzone"))
    }
    xspan <- as.numeric(diff(zz), units = "secs")
    ## specify the set of pretty timesteps
    steps <-
        list("1 sec" = list(1, format = "%S", start = "mins"),
             "2 secs" = list(2),
             "5 secs" = list(5),
             "10 secs" = list(10),
             "15 secs" = list(15),
             "30 secs" = list(30, format = "%H:%M:%S"),
             "1 min" = list(1*MIN, format = "%H:%M"),
             "2 mins" = list(2*MIN, start = "hours"),
             "5 mins" = list(5*MIN),
             "10 mins" = list(10*MIN),
             "15 mins" = list(15*MIN),
             "30 mins" = list(30*MIN),
             ## "1 hour" = list(1*HOUR),
	     "1 hour" = list(1*HOUR, format = if (xspan <= DAY) "%H:%M"
					      else paste("%b %d", "%H:%M", sep = sep)),
             "3 hours" = list(3*HOUR, start = "days"),
             "6 hours" = list(6*HOUR, format = paste("%b %d", "%H:%M", sep = sep)),
             "12 hours" = list(12*HOUR),
             "1 DSTday" = list(1*DAY, format = paste("%b", "%d", sep = sep)),
             "2 DSTdays" = list(2*DAY),
             "1 week" = list(7*DAY, start = "weeks"),
             "halfmonth" = list(MONTH/2, start = "months"),
             ## "1 month" = list(1*MONTH, format = "%b"),
	     "1 month" = list(1*MONTH, format = if (xspan < YEAR) "%b"
						else paste("%b", "%Y", sep = sep)),
             "3 months" = list(3*MONTH, start = "years"),
             "6 months" = list(6*MONTH, format = "%Y-%m"),
             "1 year" = list(1*YEAR, format = "%Y"),
             "2 years" = list(2*YEAR, start = "decades"),
             "5 years" = list(5*YEAR),
             "10 years" = list(10*YEAR),
             "20 years" = list(20*YEAR, start = "centuries"),
             "50 years" = list(50*YEAR),
             "100 years" = list(100*YEAR),
             "200 years" = list(200*YEAR),
             "500 years" = list(500*YEAR),
             "1000 years" = list(1000*YEAR))
    ## carry forward 'format' and 'start' to following steps
    for (i in seq_along(steps)) {
        if (is.null(steps[[i]]$format))
            steps[[i]]$format <- steps[[i-1]]$format
        if (is.null(steps[[i]]$start))
            steps[[i]]$start <- steps[[i-1]]$start
        steps[[i]]$spec <- names(steps)[i]
    }
    ## crudely work out number of steps in the given interval
    nsteps <- xspan / vapply(steps, `[[`, numeric(1), 1L, USE.NAMES=FALSE)
    init.i <- init.i0 <- which.min(abs(nsteps - n))
    ## calculate actual number of ticks in the given interval
    calcSteps <- function(s, lim = range(zz)) {
        startTime <- trunc_POSIXt(lim[1], units = s$start) ## FIXME: should be trunc() eventually
        at <- seqDtime(startTime, end = lim[2], by = s$spec)
	if(anyNA(at)) { at <- at[!is.na(at)]; if(!length(at)) return(at) }
	r1 <- sum(at <= lim[1])
	r2 <- length(at) + 1 - sum(at >= lim[2])
	if(r2 == length(at) + 1) { # not covering at right -- add point at right
	    nat <- seqDtime(at[length(at)], by = s$spec, length=2)[2]
	    if(is.na(nat) || !(nat > at[length(at)])) # failed
		r2 <- length(at)
	    else
		at[r2] <- nat
	}
	## Now we could see if we are *smaller* than 'n+1' and add even more at[] on both sides
	at[r1:r2]
    }
    init.at <- calcSteps(st.i <- steps[[init.i]])
    ## bump it up if below acceptable threshold
    R <- TRUE # R := TRUE iff "right"
    L.fail <- R.fail <- FALSE
    while ((init.n <- length(init.at) - 1L) < min.n) {
	if(init.i == 1L) { ## keep steps[[1]]
	    ## add new interval right or left
            if(R) {
                nat <- seqDtime(init.at[length(init.at)], by = st.i$spec, length=2)[2]
                R.fail <- is.na(nat) || !(nat > init.at[length(init.at)])
                if(!R.fail)
                    init.at[length(init.at) + 1] <- nat
            } else { # left
                nat <- seqDtime(init.at[1], by = paste0("-",st.i$spec), length=2)[2]
                L.fail <- is.na(nat) || !(nat < init.at[1])
                if(!L.fail) {
                    init.at[seq_along(init.at) + 1] <- init.at
                    init.at[1] <- nat
                }
            }
            if(R.fail && L.fail)
                stop("failed to add more ticks; 'min.n' too large?")
	    R <- !R # alternating right <-> left
	} else { # smaller step sizes
	    init.i <- init.i - 1L
	    init.at <- calcSteps(st.i <- steps[[init.i]])
	}
    }
    if (init.n == n) ## perfect
        return(makeOutput(init.at, st.i))
    ## else : have a difference dn :
    dn <- init.n - n
    if(dn > 0L) {  ## too many ticks
	## ticks "outside", on left and right, keep at least one on each side
	nl <- sum(init.at <= rx[1]) - 1L
	nr <- sum(init.at >= rx[2]) - 1L
	if(nl > 0L || nr > 0L) {
	    n.c <- nl+nr # number of removable ticks
	    if(dn < n.c) { # remove dn, not all
		nl <- round(dn * nl/n.c)
		nr <- dn - nl
	    }
	    ## remove nl on left,  nr on right:
	    init.at <- init.at[-c(seq_len(nl), length(init.at)+1L-seq_len(nr))]
	}
    } else { ## too few ticks
        ## warning("trying to add more points -- not yet implemented")
        ## but after all, 'n' is approximate
	## init.at <- calcSteps(st.i, "more ticks")
    }
    if ((dn <- length(init.at) - 1L - n) == 0L  ## perfect
	|| (dn > 0L && init.i < init.i0) # too many, but we tried init.i + 1 already
        || (dn < 0L && init.i == 1)) # too few, but init.i = 1
	return(makeOutput(init.at, st.i))

    new.i <- if (dn > 0L) ## too many ticks
		 min(init.i + 1L, length(steps))
	     else ## too few ticks (and init.i > 1):
		 init.i - 1L
    new.at <- calcSteps(steps[[new.i]])
    new.n <- length(new.at) - 1L
    ## work out whether new.at or init.at is better
    if (new.n < min.n)
        new.n <- -Inf
    if (abs(new.n - n) < abs(dn))
	makeOutput(new.at, steps[[new.i]])
    else
	makeOutput(init.at, st.i)
}


## Utility, a generalization/special case of seq.POSIXct() / seq.Date()
seqDtime <- function(beg, end, by, length=NULL) {
    if(missing(by) || !identical(by, "halfmonth"))
        return( seq(beg, end, by = by, length.out=length) )
    ## else  by == "halfmonth" => can only go forward (!)
    if(is.null(length)) {
        l2 <- NULL; i <- TRUE
    } else {
        l2 <- ceiling(length/2); i <- seq_len(length)
    }
    at <- seq(beg, end, by = "months", length.out = l2)
    at2 <- as.POSIXlt(at)
    stopifnot(length(md <- unique(at2$mday)) == 1)
    at <- as.POSIXct(at)
    ## intersperse at and at2 := 15-day-shifted( at ), via rbind():
    if(md == 1) {
        at2$mday <- 15L
    } else if(md >= 15) { # (md == 16 may happen; not seen yet)
        at2$mday <- 1L
        at2$mon <- at2$mon + 1L
        ## at2 now has wrong 'yday','wday',.. and we rely on as.POSIXct():
    } else if(md < 15) { ## e.g., southern hemisphere, seen 14
        at2$mday <- md + 14L # consistent w (1 -> 15) in 1st case; ok even in Feb.
    }
    at2$isdst <- -1L
    at2 <- rbind(at, as.POSIXct(at2), deparse.level = 0L)
    structure(at2[i], class = class(at), tzone = attr(at, "tzone"))
}


## utility function, extending the base function trunc.POSIXt.
## Ideally this should replace the original, but that should be done
## with a little more thought (what about round.POSIXt etc.?)

trunc_POSIXt <-
    function(x, units = c("secs", "mins", "hours", "days",
                "weeks", "months", "years", "decades", "centuries"),
             start.on.monday = TRUE)
{
    x <- as.POSIXlt(x)
    if (units %in% c("secs", "mins", "hours", "days"))
	return(trunc.POSIXt(x, units))
    x <- trunc.POSIXt(x, "days")
    if (length(x$sec))
        switch(units,
               weeks = {
                   x$mday <- x$mday - x$wday
                   if (start.on.monday)
                       x$mday <- x$mday + ifelse(x$wday > 0L, 1L, -6L)
               },
               months = {
                   x$mday <- 1
               },
               years = {
                   x$mday <- 1
                   x$mon <- 0
               },
               decades = {
                   x$mday <- 1
                   x$mon <- 0
                   x$year <- (x$year %/% 10) * 10
               },
               centuries = {
                   x$mday <- 1
                   x$mon <- 0
                   x$year <- (x$year %/% 100) * 100
               })
    x
}