sciplotr: GGplots with scientific themes

#' @title Break generators
#' @rdname breaks
#' @param n Controls the number of generated breaks.
#' @param modifier Affects the set of the allowed break steps.
#' @param range,limits,lim Data range passed by the \code{ggplot2} internal methods.
#' @param step Step generated by e.g. \code{fancy_step}.
#' @param breaks,brs Large breaks passed to the small breaks generator.
#'
#' @export
simple_breaks <- function(n = 5, modifier = vctrs::vec_c(1, 2, 2.5, 5)) {
    function(x) {
        x <- x[is.finite(x)]
        if (vec_is_empty(x)) {
            return(numeric())
        }
        rng <- range(x)
        generate_simple_breaks(rng, fancy_step(rng, n, modifier))
    }
}
#' @rdname breaks
#' @export
simple_minor_breaks <- function(n = 50L) {
    function(b, limits, m) {
        generate_simple_minor_breaks(b, limits, n = n)
    }
}
#' @rdname breaks
#' @export
simple_log10_breaks <- function(n = 5L) {
    function(x) {
        x <- x[is.finite(x)]
        if (vec_is_empty(x)) {
            return(numeric())
        }
        rng <- range(x)
        generate_simple_log10_breaks(rng, n)
    }
}
#' @rdname breaks
#' @export
simple_log10_minor_breaks <- function(n = 30L) {
    function(b, limits, m) {
        generate_simple_log10_minor_breaks(b, limits, n = n)
    }
}

#' @rdname breaks
#' @export
fancy_step <- function(range, n = 6, modifier = c(1, 2, 2.5, 5)) {
    modifier <- c(0.1 * modifier, modifier)

    large_steps <- 10 ^ floor(log10(abs(diff(range))))

    mod_ind <- abs(abs(diff(range)) / (modifier * large_steps) - n)
    mod_ind <- which(are_equal_f(mod_ind, min(mod_ind)))

    min(large_steps * modifier[mod_ind])
}

#' @rdname breaks
#' @export
generate_simple_breaks <- function(range, step = fancy_step(range, n = 6L, modifier = vctrs::vec_c(1, 2, 2.5, 5))) {

    step * (ceiling(range[1] / step):floor(range[2] / step))
}

#' @rdname breaks
#' @export
generate_simple_minor_breaks <- function(breaks, limits, n = 40L) {
    if (vctrs::vec_size(breaks) < 2L)
        return(double(0))
    diffs <- diff(breaks)
    # Temporarily ignore this
    #if (!are_same_all(diffs, eps = 1))
    ## Probably can handle this case also
    ##stop("Unequally spaced major breaks")
    #print(RLibs::glue_fmt("{diffs:%26.16e}"))

    df <- abs(diffs[1L])

    digit <- abs(df / log10_floor(df))

    modifier <- cc(1, 2, 5)
    #modifier <- cc(0.1 * modifier, modifier, 10 * modifier)

    if (digit %==% 2)
        modifier <- cc(0.5, 2.5,  5)
    if (digit %==% 3)
        modifier <- cc(1)#, 3) # Not sure how to resolve this
    if (digit %==% 5)
        modifier <- cc(1, 2)
    if (digit %==% 2.5)
        modifier <- cc(0.4, 2)

    modifier <- cc(0.1 * modifier, modifier, 10 * modifier)
    #print(digit)
    #print(modifier)
    step <- 0.1 * df#log10_floor(df)

    extra_rng <- cc(min(breaks) - df, max(breaks) + df)

    sizes <- abs(diff(extra_rng) / (step * modifier) - n)

    ind <- which(are_equal_f(sizes, min(sizes)))[1]

    small_breaks <- generate_simple_breaks(cc(0, df), modifier[ind] * step)

    #print(modifier[ind] * step)

    extended_breaks <-
        purrr::map(cc(min(breaks) - df, breaks, max(breaks) + df), ~ .x + small_breaks) %>%
        purrr::flatten_dbl() %>%
        unique_f

    extended_breaks <- outer_unique(extended_breaks, breaks)$x

    extended_breaks[extended_breaks >= limits[1] & extended_breaks <= limits[2]]
}

#' @rdname breaks
#' @export
generate_simple_log10_breaks <- function(lim, n = 5L) {
    tick_set <- list(
    #vctrs::vec_c(0.1, 0.2, 0.5, 1, 2, 5, 10, 20, 50),
                    #vctrs::vec_c(0.01, 0.05, 0.1, 0.5, 1, 5, 10, 50, 100),
                    vctrs::vec_c(0.01, 0.1, 1, 10, 100))
    diff <- abs(diff(log10(abs(lim))))
    if (diff <= 1) {
        breaks <- generate_simple_breaks(lim,
            step = fancy_step(lim, n = floor(1.25 * n), modifier = vctrs::vec_c(1, 2, 5)))
    }
    else if (diff <= 2.1) {
        order <- log10_floor(lim)
        ticks <- cc(1, 2, 5)
        ticks <- cc(0.1 * ticks, ticks, 10 * ticks)
        ticks <- cc(ticks * order[1], ticks * order[2])
        ticks <- unique_f(ticks)
        breaks <- ticks
    }
    else {
        breaks <- 10 ^ generate_simple_breaks(log10(lim), 1)
        get_breaks <- function(tcks)
            purrr::map(breaks, ~ tcks * .x) %>%
                purrr::flatten_dbl %>%
                    scales::discard(lim) %>%
                        unique_f(eps = 1)

        breaks <- purrr::map(tick_set, get_breaks)
        delta_lens <- abs(purrr::map_int(breaks, vctrs::vec_size) - n)
        id <- which(are_equal_f(delta_lens, min(delta_lens)))[1]

        breaks <- breaks[[id]]
    }
    breaks <- sort(breaks[breaks >= lim[1] & breaks <= lim[2]])
    return(breaks)
}

#' @rdname breaks
#' @export
generate_simple_log10_minor_breaks <- function(brs, lim, n = 30L) {
    brs <- 10 ^ brs
    lim <- 10 ^ lim
    tick_set <- list(
                    vctrs::vec_c(0.1 * (1:9), 1:9, 10 * (1:9)),
                    vctrs::vec_c(0.1, 0.5, 1, 5, 10, 50),
                    vctrs::vec_c(0.1, 1, 10))
    if (diff(log10(lim)) <= 1) {
        breaks <- generate_simple_minor_breaks(brs, lim, n)
    }
    else if (diff(log10(lim)) <= 2.1) {
        order <- log10_floor(lim)
        small_ticks <- cc(1:9)
        small_ticks <- cc(0.1 * small_ticks, small_ticks, 10 * small_ticks)
        small_ticks <- cc(small_ticks * order[1], small_ticks * order[2])
        small_ticks <- unique_f(small_ticks)
        small_ticks <- outer_unique(small_ticks, brs)[[1]]
        breaks <- small_ticks
    }
    else {
        brs_2 <- unique_f(log10_floor(brs))
        get_breaks <- function(tcks)
            purrr::map(brs_2, ~ tcks * .x) %>%
                purrr::flatten_dbl %>%
                    scales::discard(lim) %>%
                        unique_f

        breaks <- purrr::map(tick_set, get_breaks)
        delta_lens <- abs(purrr::map_int(breaks, vctrs::vec_size) - n)
        id <- which(are_equal_f(delta_lens, min(delta_lens)))

        breaks <- breaks[[id]]
        breaks <- breaks[outer_unique_which(brs, breaks)$y]
    }
    breaks <- sort(breaks[breaks >= lim[1] & breaks <= lim[2]])
    breaks <- log10(breaks)
    return(breaks)
}


new_breaks <- function(breaks, minor_breaks, name) {
    vctrs::vec_assert(name, character(), 1L)
    assertthat::assert_that(nzchar(name))

    breaks <- rlang::as_function(breaks)
    minor_breaks <- rlang::as_function(minor_breaks)

    structure(list(get_breaks = breaks, get_minor_breaks = minor_breaks, name = name), class = "breaks_gen")
}

print.breaks_gen <- function(x, ...) {
    cat("Breaks generator: ", x$name, "\n")
}