R Under development (unstable) (2026-03-16 r89642 ucrt) -- "Unsuffered Consequences" Copyright (C) 2026 The R Foundation for Statistical Computing Platform: x86_64-w64-mingw32/x64 R is free software and comes with ABSOLUTELY NO WARRANTY. You are welcome to redistribute it under certain conditions. Type 'license()' or 'licence()' for distribution details. R is a collaborative project with many contributors. Type 'contributors()' for more information and 'citation()' on how to cite R or R packages in publications. Type 'demo()' for some demos, 'help()' for on-line help, or 'help.start()' for an HTML browser interface to help. Type 'q()' to quit R. > # $Id: $ > # Copyright (c) 2025-2026 Hiroshi Hakoyama > # > # Redistribution and use in source and binary forms, with or without > # modification, are permitted provided that the following conditions are > # met: > # > # Redistributions of source code must retain the above copyright > # notice, this list of conditions and the following disclaimer. > # > # Redistributions in binary form must reproduce the above copyright > # notice, this list of conditions and the following disclaimer in > # the documentation and/or other materials provided with the > # distribution. > # > # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS > # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT > # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR > # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT > # HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, > # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT > # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, > # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY > # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT > # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE > # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. > > library(extr) > repr_mode <- extr:::repr_mode > format_by_mode <- extr:::format_by_mode > > message("=== extr print/format tests start ===") === extr print/format tests start === > > # --- helper assertions --- > aeq <- function(x, y, tol = 1e-12, msg = "not equal") { + if (is.na(x) && is.na(y)) return(invisible(TRUE)) + if (!isTRUE(all.equal(x, y, tolerance = tol))) { + stop(sprintf("AEQ FAIL: %s\nx=%s\ny=%s", msg, deparse(x), deparse(y))) + } + invisible(TRUE) + } > > atrue <- function(cond, msg = "assertion failed") { + if (!isTRUE(cond)) stop(sprintf("ASSERT FAIL: %s", msg)) + invisible(TRUE) + } > > acontains <- function(lines, pattern, msg = "pattern not found") { + if (!any(grepl(pattern, lines))) { + stop(sprintf("NOT FOUND: %s\npattern: %s", msg, pattern)) + } + invisible(TRUE) + } > > # --- 1) repr_mode --- > test_repr_mode <- function() { + aeq(repr_mode(0.2), "linear_G", msg = "linear case") + aeq(repr_mode(1e-310), "log_G", msg = "tiny probability") + aeq(repr_mode(1 - 1e-20), "log_Q", msg = "near one") + aeq(repr_mode(NaN), "undefined", msg = "NaN handling") + message("ok: repr_mode") + } > > # --- 2) format_by_mode --- > test_format_by_mode <- function() { + out_p <- format_by_mode( + mode = "linear_G", kind = "point", + linear_g = 0.123456, log_g = NA_real_, log_q = NA_real_, + ci_linear_g = c(0.01, 0.9), ci_log_g = c(NA_real_, NA_real_), + ci_log_q = c(NA_real_, NA_real_), digits = 5 + ) + acontains(out_p, "^0\\.12346", "linear point") + + out_lo <- format_by_mode( + "linear_G", "lower", 0.2, NA, NA, c(0.0034017, 0.99), c(NA, NA), + c(NA, NA), digits = 6 + ) + acontains(out_lo, "^0\\.0034017(0)?$", "linear lower") + + out_lg <- format_by_mode( + "log_G", "point", NA, log(1e-20), NA, + c(NA, NA), c(log(1e-25), log(1e-15)), c(NA, NA), digits = 5 + ) + atrue(grepl("^10\\^\\([^()]+\\)$", out_lg), "log_G shape") + exp_str <- sub("^10\\^\\(([^()]+)\\)$", "\\1", out_lg) + exp_num <- suppressWarnings(as.numeric(exp_str)) + atrue(is.finite(exp_num), "log_G exponent numeric") + aeq(exp_num, -20, tol = 1e-8, msg = "log_G exponent ~= -20") + + g_near1 <- 1 - 1e-9 + out_lq <- format_by_mode( + "log_Q", "point", NA, NA, log(1 - g_near1), + c(NA, NA), c(NA, NA), + c(log(1 - (1 - 1e-10)), log(1 - (1 - 1e-8))), + digits = 3 + ) + atrue(grepl("^1 - 10\\^\\(", out_lq), "log_Q point") + + out_nf <- format_by_mode( + "log_G", "upper", NA, NA, NA, + c(NA, NA), c(NA, NA), c(NA, NA), digits = 5 + ) + aeq(out_nf, "NA", "non-finite returns NA") + + message("ok: format_by_mode") + } > > # --- 3) ext_di core --- > test_ext_di_core <- function() { + set.seed(1) + time <- 1:30 + pop <- round(exp(seq(log(200), log(80), length.out = length(time)))) + dat <- data.frame(time = time, population = pop) + + res <- ext_di(dat, th = 50, ne = 10, digits = 6) + atrue(inherits(res, "ext_di"), "class ext_di") + needed <- c( + "linear_g", "log_g", "log_q", "ci_linear_g", "ci_log_g", "ci_log_q", + "repr_point", "repr_lower", "repr_upper", "digits" + ) + atrue(all(needed %in% names(res)), "fields present") + + atrue(is.numeric(res$Growth.rate), "mu numeric") + atrue(is.numeric(res$Variance), "s numeric") + atrue(is.numeric(res$Unbiased.variance), "us numeric") + atrue(is.numeric(res$aic), "aic numeric") + + atrue(length(res$ci_linear_g) == 2, "ci_linear length 2") + atrue(length(res$ci_log_g) == 2, "ci_log_g length 2") + atrue(length(res$ci_log_q) == 2, "ci_log_q length 2") + + message("ok: ext_di core") + } > > # --- 4) print.ext_di behavior --- > test_print_ext_di <- function() { + time <- 1:20 + pop <- round(seq(100, 50, length.out = length(time))) + dat <- data.frame(time = time, population = pop) + + res_small <- ext_di(dat, th = 4, ne = 1, digits = 5) + lines_small <- capture.output(print(res_small)) + atrue(any(grepl("10\\^\\(", lines_small)), "log form appears") + + res_large <- ext_di(dat, th = 250, ne = 1, digits = 10) + lines_large <- capture.output(print(res_large)) + atrue(any(grepl("0\\.99999|1 - 10\\^\\(", lines_large)), + "high precision near 1") + + lines_7 <- capture.output(print(res_large, digits = 7)) + atrue(any(grepl("0\\.999999|1 - 10\\^\\(", lines_7)), + "print(digits=7) respected") + + message("ok: print.ext_di") + } > > # --- 5) error handling --- > test_errors <- function() { + bad <- tryCatch(ext_di("bad"), error = identity) + atrue(inherits(bad, "error"), "non-df error") + + bad2 <- tryCatch( + ext_di(data.frame(a = 1:3, b = c(1, 0, 2))), + error = identity + ) + atrue(inherits(bad2, "error"), "n<1 error") + + dat <- data.frame( + time = c(0, 1, 1, 2), + population = c(10, 11, 12, 13) + ) + bad3 <- tryCatch(ext_di(dat), error = identity) + atrue(inherits(bad3, "error"), "non-increasing time") + + message("ok: error handling") + } > > test_print_ext_di_oear <- function() { + time <- 1:30 + pop <- round(seq(120, 60, length.out = length(time))) + dat <- data.frame(time = time, population = pop) + + res <- ext_di(dat, th = 100, ne = 10, method = "oear", digits = 6) + lines <- capture.output(print(res)) + + acontains( + lines, "Process variance \\(OEAR\\):", "OEAR variance label" + ) + acontains(lines, "AR\\(1\\) pre-whitening rho:", "rho row") + acontains(lines, "Bartlett lag truncation \\(j\\):", "j row") + atrue( + !any(grepl("Unbiased variance:", lines)), + "no unbiased row for oear" + ) + atrue( + !any(grepl("AIC for the distribution of N:", lines)), + "no AIC row for oear" + ) + } > > # --- runner with summary --- > run_all_extr_base_tests <- function() { + passed <- TRUE + tryCatch({ + test_repr_mode() + test_format_by_mode() + test_ext_di_core() + test_print_ext_di() + test_errors() + test_print_ext_di_oear() + }, error = function(e) { + passed <<- FALSE + message("Test failure: ", conditionMessage(e)) + }) + + if (passed) { + emojis <- c("\U1F389", "\U1F638", "\U1F3C5", "\U1F308") + cat("All base-R numeric tests passed", sample(emojis, 1), "\n") + } else { + stop("Some numeric tests failed \u274C") + } + invisible(passed) + } > > run_all_extr_base_tests() ok: repr_mode ok: format_by_mode ok: ext_di core ok: print.ext_di ok: error handling All base-R numeric tests passed 🎉 > > proc.time() user system elapsed 0.35 0.17 0.45