new functions for index construction

huizezhang-sherry · Jul 18, 2022 · e507272 · e507272
1 parent e97069c
commit e507272
Show file tree

Hide file tree

Showing 6 changed files with 108 additions and 2 deletions.
diff --git a/NAMESPACE b/NAMESPACE
@@ -64,6 +64,7 @@ export(key_vars)
 export(match_sites)
 export(match_spatial)
 export(match_temporal)
+export(normalising)
 export(plot_map)
 export(prep_data)
 export(prep_edges)
@@ -73,6 +74,7 @@ export(slice_nearby)
 export(spatial)
 export(strip_rowwise)
 export(switch_key)
+export(ts_aggregate)
 export(unfold)
 import(rlang)
 import(vctrs)
@@ -113,6 +115,7 @@ importFrom(lubridate,"%within%")
 importFrom(lubridate,days)
 importFrom(lubridate,hours)
 importFrom(lubridate,minutes)
+importFrom(lubridate,month)
 importFrom(lubridate,seconds)
 importFrom(lubridate,years)
 importFrom(ncdf4,ncvar_get)
@@ -123,6 +126,9 @@ importFrom(rlang,sym)
 importFrom(sf,st_area)
 importFrom(sf,st_coordinates)
 importFrom(sf,st_is_empty)
+importFrom(stats,embed)
+importFrom(stats,na.omit)
+importFrom(stats,qnorm)
 importFrom(stringr,word)
 importFrom(styler,style_text)
 importFrom(tibble,"%>%")

diff --git a/R/cubble-package.R b/R/cubble-package.R
@@ -6,6 +6,9 @@
 #' @importFrom rlang .data quo_is_missing sym as_name
 #' @importFrom cli cli_abort cli_inform
 #' @importFrom tsibble index as_tsibble
+#' @importFrom lubridate %m+% hours days minutes seconds years %within% month
+#' @importFrom stats embed na.omit qnorm
+#'
 #' @aliases cubble-package
 #' @keywords internal
 "_PACKAGE"

diff --git a/R/matching.R b/R/matching.R
@@ -249,7 +249,6 @@ match_postprocessing <- function(major, minor, match_table) {
 
 #' @export
 #' @rdname matching
-#' @importFrom lubridate %within%
 match_temporal <- function(major,
                            minor,
                            temporal_by,

diff --git a/R/netcdf.R b/R/netcdf.R
@@ -39,7 +39,6 @@ extract_longlat <- function(data){
 }
 
 #' @importFrom stringr word
-#' @importFrom lubridate %m+% hours days minutes seconds years
 #' @export
 #' @rdname netcdf
 extract_time <- function(data){

diff --git a/R/pipeline.R b/R/pipeline.R
@@ -0,0 +1,69 @@
+#' Pipeline for index calculation
+#'
+#' @param data a cubble object
+#' @param scale the time scale used for aggregation, in month
+#' @param var the variable to aggregate on
+#'
+#' @return a long cubble
+#' @export
+#' @rdname pipeline
+ts_aggregate <- function(data, scale, var){
+  test_cubble(data)
+
+  if (form(data) == "nested") data <- data %>% face_temporal()
+
+  var <- enquo(var)
+  id <- sym(key_vars(data))
+  date <- sym(index(data))
+  new_name <- paste0(as_label(var), "_agg")
+
+
+
+  data %>%
+    dplyr::mutate(!!new_name := c(
+      rep(NA, scale-1), rowSums(stats::embed(!!var, scale), na.rm = TRUE)
+      )) %>%
+    stats::na.omit()
+}
+
+
+#' @param dist a distribution function, see details
+#' @param gran the granulate for calculating the index, default to "month"
+#' @param var the variable used to calculate the index
+#'
+#' @return a tibble object (end of a pipeline)
+#' @export
+#' @rdname pipeline
+normalising <- function(data, dist, gran = "month", var){
+  test_cubble(data)
+
+  var <- enquo(var)
+  id <- sym(key_vars(data))
+  date <- sym(index(data))
+
+
+  if (quo_is_null(var)){
+    found <- grepl("_agg", colnames(data))
+    if (any(found)){
+      var <- quo(colnames(data)[found])
+    } else{
+      cli::cli_abort("Please specify the variable to normalising with {.code var =}")
+    }
+  }
+
+  if (grepl("_agg", as_label(var))){
+    var <- sym(sub("_agg","", quo_get_expr(var)))
+  }
+
+  created_fit <- paste0(as_label(var), "_fit")
+  created_idx <- paste0(as_label(var), "_idx")
+
+    data %>%
+      dplyr::group_by(g = do.call(gran, list(!!date))) %>%
+      dplyr::mutate(
+        !!created_fit := do.call(dist, list(!!var, !!var)),
+        !!created_idx := stats::qnorm(!!sym(created_fit))
+      ) %>%
+      dplyr::select(-.data$g)
+}
+
diff --git a/man/pipeline.Rd b/man/pipeline.Rd