add dt aggregate

DESCRIPTION

@@ -15,7 +15,7 @@ Imports:
     ggplot2,
     jsonlite,
     magrittr,
-    purrr, progress,
+    purrr, rlang, progress,
     lubridate,
     data.table, fst,
     openxlsx,

NAMESPACE

@@ -56,9 +56,12 @@ export(dev_open)
 export(dir.show)
 export(dir2)
 export(dt_chr2num)
+export(dt_day2mon)
+export(dt_day2year)
 export(dt_ddply)
 export(dt_dlply)
 export(dt_ldply)
+export(dt_mean)
 export(dt_round)
 export(edit_r_environ)
 export(edit_r_profile)
@@ -78,6 +81,7 @@ export(fwrite)
 export(fwrite2)
 export(gc_cluster)
 export(gc_linux)
+export(get_yearly)
 export(getwd_clip)
 export(git_commit)
 export(git_commit_amend)
@@ -95,6 +99,7 @@ export(install_git)
 export(install_gitee)
 export(install_github)
 export(install_gitlab)
+export(interp_hisavg_month)
 export(is.data.table)
 export(is_empty)
 export(is_win)
@@ -283,6 +288,9 @@ importFrom(purrr,transpose)
 importFrom(remotes,install_git)
 importFrom(remotes,install_github)
 importFrom(remotes,install_gitlab)
+importFrom(rlang,eval_bare)
+importFrom(rlang,expr)
+importFrom(rlang,parse_exprs)
 importFrom(rstudioapi,getActiveDocumentContext)
 importFrom(rstudioapi,getSourceEditorContext)
 importFrom(rstudioapi,modifyRange)

R/aggregate.R

@@ -0,0 +1,62 @@
+#' @export 
+dt_mean <- function(d, by) {
+  by = substitute(by)
+  d[, lapply(.SD, mean, na.rm = TRUE), by]
+}
+
+#' @importFrom rlang parse_exprs eval_bare expr
+#' @export
+get_yearly <- function(d, by = NULL) {
+  by <- by %||% ""
+  .by <- parse_exprs(by)
+  by2 <- expr(list(year(date), !!!.by))
+
+  expr <- expr(d[, lapply(.SD, mean, na.rm = TRUE), !!by2])
+  # print(expr)
+  rlang::eval_bare(expr)
+}
+
+#' @export 
+dt_day2mon <- function(dat, nmiss_day_per_mon = 3, ...) {
+  # dat %<>% fix_uncontinue()
+  dat_mon <- dat[, .(
+    value = mean(value, na.rm = TRUE),
+    # nmiss =  days_in_month(date[1]) - sum(!is.na(value))
+    n_valid = sum(!is.na(value))
+    # nmiss = sum(is.na(value))
+  ), .(site, date = date_ym(date))]
+  dat_mon %<>% mutate(n_miss = days_in_month(date) - n_valid)
+  dat_mon
+}
+
+#' dt_day2year
+#' @param dat A data.table, at least with the columns of `c("site", "date", "value")`
+#' @export 
+dt_day2year <- function(dat, 
+  nmiss_day_per_mon = 3, nmiss_MonPerYear = 0, nmin_year = 55, ...) 
+{
+  dat_mon <- dt_day2mon(dat, nmiss_day_per_mon)
+  dat_year <- dat_mon[n_miss <= nmiss_day_per_mon, .(
+    value = mean(value, na.rm = TRUE),
+    n_miss = 12 - .N
+  ), .(site, year(date))]
+
+  ans <- dat_year[n_miss <= nmiss_MonPerYear, .(site, year, value)] 
+  # 最长的数据有62年，至少要有55年的数据
+  info <- ans[, .N, site]
+  ans = merge(ans, info[N >= nmin_year, .(site)]) # yeraly data
+  list(mon = dat_mon[, .(site, date, value)], year = ans)
+}
+
+# ' @param df_mon c("site", "date", "value")
+#' @export
+interp_hisavg_month <- function(df_mon) {
+  df_mon %<>% mutate(month = month(date))
+  d_his <- df_mon[, lapply(.SD, mean, na.rm = TRUE), .(site, month(date))] %>%
+    rename(interp_mon = value)
+
+  ans <- merge(df_mon, d_his, by = c("site", "month"), sort = FALSE)
+  ans[is.na(value), value := interp_mon]
+  ans %<>% setkeyv(c("site", "date"))
+  ans[, .(site, date, value)]
+}

R/examples/test-rio.Rmd

@@ -0,0 +1,11 @@
+```{r}
+library(Ipaper)
+
+
+
+```
+
+```{r}
+rm(list = ls())
+load("a.rda")
+```

R/rio.R

@@ -13,26 +13,33 @@ import_fst <- function(
 export <- function(x, path, ...) {
   ext <- tools::file_ext(path) %>% tolower()
   if (ext == "rda") {
-    save(x, file = path, ...)
+    var = deparse(substitute(x))
+    eval(parse(text=glue("save({var}, ..., file = path, envir = parent.frame())")))
+    # print(var)
+    # save(x, file = path, ...)
   } else if (ext == "rds") {
     saveRDS(x, path, ...)
   } else if (ext == "fst") {
     write_fst(x, path, ...)
   } else if (ext == "csv") {
     fwrite(x, path, ...)
+  } else {
+    message("unsupported file type!")
   }
 }
 
 #' @export
 import <- function(path, ...) {
   ext <- tools::file_ext(path) %>% tolower()
   if (ext == "rda") {
-    load(path)
+    load(path, envir = parent.frame())
   } else if (ext == "rds") {
     readRDS(path)
   } else if (ext == "fst") {
     import_fst(path, ...)
   } else if (ext == "csv") {
     fread(x, path, ...)
+  } else {
+    message("unsupported file type!")
   }
 }