add more tests

.Rbuildignore

@@ -7,3 +7,4 @@
 ^vignettes$
 ^inst/font$
 ^\.github$
+^\.covrignore$

.covrignore

@@ -0,0 +1,10 @@
+R/addin.R
+R/cmd_func.R
+R/getwd_clip.R
+R/git.R
+R/module.R
+R/parallel_init.R
+R/path_func.R
+R/purrrprogress.R
+R/set_font.R
+R/tools_pdf.R

DESCRIPTION

@@ -41,5 +41,5 @@ Suggests:
     grid, 
     gridExtra
 VignetteBuilder: knitr
-RoxygenNote: 7.2.2
+RoxygenNote: 7.2.3
 Roxygen: list(markdown = TRUE)

Ipaper.Rproj

@@ -6,12 +6,14 @@ AlwaysSaveHistory: Default
 
 EnableCodeIndexing: Yes
 UseSpacesForTab: Yes
-NumSpacesForTab: 4
+NumSpacesForTab: 2
 Encoding: UTF-8
 
 RnwWeave: Sweave
 LaTeX: pdfLaTeX
 
+AutoAppendNewline: Yes
+StripTrailingWhitespace: Yes
 LineEndingConversion: Windows
 
 BuildType: Package

R/arr_trend.R

@@ -24,52 +24,6 @@ slope_arr <- function(arr, FUN = rtrend::slope_mk, return.list = FALSE) {
   }
 }
 
-# #' calculate MK slope of rast object
-# #'
-# #' @param r A rast object
-# #' @param ... ignored
-# #'
-# #' @seealso [terra::rast()]
-# #' @importFrom terra as.array plot rast ext
-# #' @export
-# slope_rast <- function(r, period = c(2001, 2020),
-#     fun = rtrend::slope_mk,
-#     outfile = NULL, overwrite = FALSE, ...)
-# {
-#     if (is.character(r)) r = rast(r, ...)
-#     if (!is.null(period)) {
-#         # `r` should have time information
-#         year = year(time(r))
-#         ind = which(year >= period[1] & year <= period[2])
-#         arr = as.array(r[[ind]]) # 3d array
-#     } else {
-#         arr = as.array(r) # 3d array
-#     }
-#     t = slope_arr(arr, fun = fun, return.list = FALSE) # 3d array
-#     r_target = rast(r, nlyrs = 2) %>%
-#         set_names(c("slope", "pvalue"))
-#         # vals = t,)# vals = ans,
-#     values(r_target) = t # !note that `t` should be a 3d array
-#     # `vals`, and `values`, result is different
-#     if (!is.null(outfile)) {
-#         if (!file.exists(outfile) || overwrite) {
-#             # if (file.exists(outfile)) file.remove(outfile)
-#             writeRaster(r_target, outfile, overwrite = TRUE)
-#         }
-#     }
-#     r_target
-# }
-
-# slope_nc <- function(file, varname = 0) {
-#     period = c("2001-01-01", "2020-12-31")
-#     arr <- ncread(file, varname, DatePeriod = period)$data[[1]]
-#     info = ncdim_get(file)
-
-#     t = slope_arr(arr)
-#     r = get_grid.lonlat(info$lon, info$lat)
-#     r@data = t %>% list2df()
-#     r
-# }
 
 # list2df <- function(x) {
 #     lapply(x, as.numeric) %>% as.data.frame()

R/group_apply.R

@@ -47,7 +47,9 @@ upper_envelope <- function(x, y, interval = c(.50, .80, .90, .95), nchunk = 50)
 
     d_prob = data.table(I = seq_along(interval),
                         interval = sprintf("%d%%", interval*100) %>% {factor(., rev(.))},
-                        lower = (1 - interval)/2, upper = 1 - (1 - interval)/2, mid = 0.5)
+                        lower = (1 - interval)/2, 
+                        upper = 1 - (1 - interval)/2, 
+                        mid = 0.5)
 
     rows = (1:nrow(d_prob)) %>% set_names(., .)
     d = foreach(i = rows) %do% {

R/label_tag.R

@@ -9,10 +9,10 @@
 #' @export
 label_tag <- function(labels, tag = TRUE, expression = TRUE, letter_begin = 1) {
     n <- length(labels)
-    tags = c(letters, LETTERS)
+    tags <- c(letters, LETTERS)
     if (expression) {
         sapply(seq_along(labels), function(i) {
-            name = labels[[i]]
+            name <- labels[[i]]
             data <- list(tag = tags[i + letter_begin - 1], x = name)
             if (tag) {
                 eval(substitute(expression(bold("(" * tag * ")" ~ x)), data))
@@ -40,7 +40,7 @@ char2expr <- function(labels) {
 #' @param collapse an optional character string to separate the results. Not NA_character_.
 #'
 #' @export
-char2script <- function(x, collapse = '"') {
+char2script <- function(x, collapse = '"', verbose = TRUE) {
     if (is.list(x)) {
         x <- names(x)
     }
@@ -52,7 +52,7 @@ char2script <- function(x, collapse = '"') {
     script <- paste(x, collapse = collapse) %>% paste0(head, ., tail)
 
     if (.Platform$OS.type == "windows") writeLines(script, "clipboard")
-    cat(script)
+    if (verbose) cat(script) else script
 }
 
 #' @export

R/main_dplyr.R

@@ -7,13 +7,14 @@ NULL
 #' @rdname dt_tools
 #' @export
 dt_round <- function(d, digits = 2) {
-    mutate(d, across(where(is.double), ~ round(.x, digits)))
+  mutate(d, across(where(is.double), ~ round(.x, digits)))
 }
 
 #' @rdname dt_tools
 #' @export
-dt_chr2num <- function(d) {
-    mutate(d, across(where(is.character), ~ as.numeric(.x)))
+dt_chr2num <- function(d, fun = as.numeric) {
+  # as.integer
+  mutate(d, across(where(is.character), ~ fun(.x)))
 }
 
 # https://stackoverflow.com/questions/54774280/plyrddply-equivalent-in-dplyr
@@ -22,19 +23,25 @@ dt_chr2num <- function(d) {
 #' @importFrom data.table dcast
 #' @export
 dcast2 <- function(d, by, value.var = "value", ...) {
-    vars_left <- setdiff(colnames(d), c(by, value.var)) %>% paste(collapse = "+")
-    vars_right <- by %>% paste(collapse = "+")
-    formula <- as.formula(sprintf("%s~%s", vars_left, vars_right))
-    dcast(d, formula, value.var = value.var, ...)
+  vars_left <- setdiff(colnames(d), c(by, value.var)) %>% paste(collapse = "+")
+  vars_right <- by %>% paste(collapse = "+")
+  formula <- as.formula(sprintf("%s~%s", vars_left, vars_right))
+  dcast(d, formula, value.var = value.var, ...)
 }
 
-#' @export 
+#' @export
 make_dt <- function(..., ncol = 3) {
-    x <- list(...)
-    n <- length(x)
-    nrow <- floor(n / ncol)
-    lapply(1:nrow, function(i) {
-        ind <- seq((i - 1) * ncol + 1, i * ncol)
-        x[ind] %>% as.data.table()
-    }) %>% do.call(rbind, .)
+  x <- list(...)
+  n <- length(x)
+  nrow <- floor(n / ncol)
+  lapply(1:nrow, function(i) {
+    ind <- seq((i - 1) * ncol + 1, i * ncol)
+    x[ind] %>% as.data.table()
+  }) %>% do.call(rbind, .)
 }
+
+# tribble(
+#   ~x,  ~y,
+#   "a", 1:3,
+#   "b", 4:6
+# )

R/stat-quantile.R

@@ -1,50 +1,47 @@
 #' @export
-stat_sd <- function(x, digit = 2, ...){
-    x <- x[!is.na(x)]
-    y <- mean(x)
-    ymedian = median(x)
-    sd <- sd(x)
-    fmt <- sprintf("%%.%df±%%.%df", digit, digit)
-    label <- sprintf(fmt, ymedian, sd)
-    listk(y, ymin = y-sd, ymax = y+sd, ymedian, sd, label)
+stat_sd <- function(x, digit = 2, ...) {
+  x <- x[!is.na(x)]
+  y <- mean(x)
+  ymedian <- median(x)
+  sd <- sd(x)
+  fmt <- sprintf("%%.%df±%%.%df", digit, digit)
+  label <- sprintf(fmt, ymedian, sd)
+  listk(y, ymin = y - sd, ymax = y + sd, ymedian, sd, label)
 }
 
 # 25% and 75% quantile
 #' @export
-stat_quantile2 <- function(x, probs = c(0.25, 0.75), ...){
-    # browser()
-    x <- x[!is.na(x)]
-    y <- median(x)
-    # sd <- sd(x)
-    r <- quantile(x, probs = probs, na.rm = TRUE)
-    listk(y = y, ymin = r[[1]], ymax = r[[2]])
+stat_quantile2 <- function(x, probs = c(0.25, 0.75), ...) {
+  x <- x[!is.na(x)]
+  y <- median(x)
+  # sd <- sd(x)
+  r <- quantile(x, probs = probs, na.rm = TRUE)
+  listk(y = y, ymin = r[[1]], ymax = r[[2]])
 }
 
 #' @export
-box_qtl <- function(x){
-    x <- stats::na.omit(x)
-    quantile(x, c(0.1, 0.9)) %>% set_names(c("ymin", "ymax"))
+box_qtl <- function(x, probs = c(0.1, 0.9), ...) {
+  x <- stats::na.omit(x)
+  quantile(x, probs) %>% set_names(c("ymin", "ymax"))
 }
 
-geom_quantile2 <- function(){
-    # browser()
-    p_attribute <- ggplot(d[variable != "EOS"], aes(variable, perc, fill = variable)) + 
-        stat_boxplot(geom ='errorbar', width = 0.5) +
-        geom_boxplot2(outlier.size = -1) + 
-        stat_summary(fun.data = FUN_lab, colour = "black", size = fontsize_statistic, geom = "text", vjust = -0.5) +
-        labs(y = "Relative contribution to EOS change (%)", x = NULL)
-}
+# geom_quantile2 <- function() {
+#   ggplot(d[variable != "EOS"], aes(variable, perc, fill = variable)) +
+#     stat_boxplot(geom = "errorbar", width = 0.5) +
+#     geom_boxplot2(outlier.size = -1) +
+#     stat_summary(fun.data = FUN_lab, colour = "black", size = fontsize_statistic, geom = "text", vjust = -0.5) +
+#     labs(y = "Relative contribution to EOS change (%)", x = NULL)
+# }
 
-# stat_summary(fun.data = stat_quantile, colour = "black", size = 1, geom = "errorbar")
+# stat_summary(fun.data = stat_quantile2, colour = "black", size = 1, geom = "errorbar")
 
-#' quantile_envelope
 #' @export
-quantile_envelope <- function(x, alpha){
-    names <- "ymean"
-    # if (alpha != 0.5) {
-        alpha <- c(alpha, 1-alpha)
-        names <- c("ymin", "ymax")
-    # }
-    res <- quantile(x, alpha, na.rm = T)
-    set_names(res, names)
+quantile_envelope <- function(x, alpha = 0.25, ...) {
+  names <- "ymean"
+  # if (alpha != 0.5) {
+  alpha <- c(alpha, 1 - alpha)
+  names <- c("ymin", "ymax")
+  # }
+  res <- quantile(x, alpha, na.rm = T)
+  set_names(res, names)
 }

R/tools.R

@@ -22,7 +22,7 @@ fprintf <- function(fmt, ...) cat(sprintf(fmt, ...))
 #' @export
 runningId <- function(i, step = 1, N, prefix = "") {
   perc <- ifelse(missing(N), "", sprintf(", %.1f%% ", i / N * 100))
-  if (mod(i, step) == 0) cat(sprintf("[%s] running%s %d ...\n", prefix, perc, i))
+  if (mod(i, step) == 0) fprintf("[%s] running%s %d ...\n", prefix, perc, i)
 }
 
 #' @export
@@ -74,8 +74,8 @@ unique_length <- function(x) {
 }
 
 #' @export
-unique_sort <- function(x) {
-  unique(x) %>% sort()
+unique_sort <- function(x, ..., na.last = TRUE) {
+  unique(x) %>% sort(..., na.last = na.last)
 }
 
 #' @export