Merge pull request #18 from harphub/develop

Merge develop

DESCRIPTION

@@ -1,29 +1,32 @@
 Package: harpCore
 Title: Core functions and methods for the harp ecosystem
-Version: 0.0.0.9000
+Version: 0.2.0
 Authors@R: 
     person("Andrew", "Singleton", , "[email protected]", role = c("aut", "cre"))
-Description: harp is an collection of packages for reading, analysing and 
+Description: harp is a collection of packages for reading, analysing and 
   visualizing meteorological, climate and ocean data. harpCore provides functions, 
   methods and data structures that are common to all harp packages. 
 License: Apache License (>= 2)
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Suggests: 
+    maps,
     testthat (>= 3.0.0)
 Config/testthat/edition: 3
 Imports: 
     cli,
-    dplyr,
+    dplyr (>= 1.1),
+    glue,
     magrittr,
     matrixStats,
     meteogrid,
     pillar,
+    purrr,
     Rcpp,
     rlang,
     tibble,
-    tidyr,
+    tidyr (>= 1.1),
     vctrs
 Remotes:
     harphub/meteogrid

NAMESPACE

@@ -25,16 +25,24 @@ S3method(as_unixtime,numeric)
 S3method(bind,default)
 S3method(bind,harp_list)
 S3method(c,harp_list)
+S3method(common_cases,harp_df)
+S3method(common_cases,harp_list)
 S3method(cumsum_2d,array)
 S3method(cumsum_2d,geofield)
 S3method(cumsum_2d,harp_geolist)
+S3method(decum,data.frame)
 S3method(decum,harp_anl_grid_df)
 S3method(decum,harp_det_grid_df)
 S3method(decum,harp_det_point_df)
 S3method(decum,harp_ens_grid_df)
 S3method(decum,harp_ens_point_df)
 S3method(decum,harp_list)
+S3method(deharp,default)
+S3method(deharp,harp_list)
 S3method(diff,harp_geolist)
+S3method(ens_mean_and_var,harp_ens_grid_df)
+S3method(ens_mean_and_var,harp_ens_point_df)
+S3method(ens_mean_and_var,harp_list)
 S3method(ens_prob,harp_ens_grid_df)
 S3method(ens_prob,harp_ens_point_df)
 S3method(ens_prob,harp_geolist)
@@ -61,6 +69,14 @@ S3method(geo_transform,geodomain)
 S3method(geo_transform,geofield)
 S3method(geo_transform,harp_geolist)
 S3method(geo_transform,harp_grid_df)
+S3method(geo_upscale,geofield)
+S3method(geo_upscale,geolist)
+S3method(geo_upscale,harp_grid_df)
+S3method(geo_upscale,harp_list)
+S3method(geo_weights,geodomain)
+S3method(geo_weights,geofield)
+S3method(geo_weights,harp_geolist)
+S3method(geo_weights,harp_grid_df)
 S3method(geo_weights_points,geodomain)
 S3method(geo_weights_points,geofield)
 S3method(geo_weights_points,harp_geolist)
@@ -81,7 +97,6 @@ S3method(get_domain,default)
 S3method(get_domain,geodomain)
 S3method(get_domain,geofield)
 S3method(get_domain,harp_geolist)
-S3method(group_by,harp_df)
 S3method(inner_join,harp_list)
 S3method(is.na,geofield)
 S3method(is.na,harp_geolist)
@@ -118,6 +133,7 @@ S3method(print,harp_ens_xs_df)
 S3method(print,harp_ens_xs_df_long)
 S3method(print,harp_geolist)
 S3method(print,harp_list)
+S3method(print,harp_verif)
 S3method(pull,harp_list)
 S3method(rename,harp_list)
 S3method(rename_with,harp_list)
@@ -137,7 +153,6 @@ S3method(std_dev,harp_geolist)
 S3method(to_seconds,character)
 S3method(to_seconds,numeric)
 S3method(transmute,harp_list)
-S3method(ungroup,harp_df)
 S3method(unique_col,data.frame)
 S3method(unique_col,harp_list)
 S3method(variance,default)
@@ -172,8 +187,12 @@ export(as_ymdh)
 export(as_ymdhm)
 export(as_ymdhms)
 export(bind)
+export(common_cases)
 export(cumsum_2d)
 export(decum)
+export(define_domain)
+export(deharp)
+export(ens_mean_and_var)
 export(ens_prob)
 export(ens_stats)
 export(expand_date)
@@ -182,12 +201,15 @@ export(filter)
 export(geo_opts_points)
 export(geo_opts_regrid)
 export(geo_opts_subgrid)
+export(geo_opts_upscale)
 export(geo_opts_xsection)
 export(geo_opts_zoom)
 export(geo_points)
 export(geo_regrid)
 export(geo_subgrid)
 export(geo_transform)
+export(geo_upscale)
+export(geo_weights)
 export(geo_weights_points)
 export(geo_weights_regrid)
 export(geo_weights_xsection)
@@ -202,7 +224,7 @@ export(is_geolist)
 export(is_harp_df)
 export(is_harp_list)
 export(join_to_fcst)
-export(make_domain)
+export(make_verif_groups)
 export(nbhd_smooth)
 export(nbhd_smooth_cumsum)
 export(parse_thresholds)
@@ -239,7 +261,6 @@ importFrom(dplyr,anti_join)
 importFrom(dplyr,arrange)
 importFrom(dplyr,filter)
 importFrom(dplyr,full_join)
-importFrom(dplyr,group_by)
 importFrom(dplyr,inner_join)
 importFrom(dplyr,left_join)
 importFrom(dplyr,mutate)
@@ -250,7 +271,6 @@ importFrom(dplyr,right_join)
 importFrom(dplyr,select)
 importFrom(dplyr,semi_join)
 importFrom(dplyr,transmute)
-importFrom(dplyr,ungroup)
 importFrom(magrittr,"%>%")
 importFrom(rlang,.data)
 useDynLib(harpCore, .registration = TRUE)

R/data.R

@@ -52,3 +52,32 @@
 #' @format NULL
 #' @rdname example_data
 "anl_grid_df"
+
+#' List of Weather Stations
+#'
+#' A dataset containing site ID, latitude, longitude, elevation and name of
+#' 13417 weather stations world wide.
+#'
+#' @format A data frame with 13417 rows and 5 variables: \describe{
+#'   \item{SID}{station ID number} \item{lat}{latitude of the station, in
+#'   decimal degrees} \item{lon}{longitude of the station, in decimal degrees}
+#'   \item{elev}{elevation of the station, in metres} \item{name}{the name of
+#'   the station}}
+#'
+#' @source HIRLAM station list
+"station_list"
+
+#' Weather station IDs with regional groups
+#'
+#' A dataset with station IDs and geographic groups they belong it. Can be used
+#' to do grouped verification by joining the station_groups to a harp_fcst list
+#' and running the verification with \code{groupings = c("leadtime", "group")}.
+#' Note that many stations belong to more than one group
+#'
+#' @format A data frame with 6001 rows and 2 variables: \describe{
+#'   \item{SID}{station ID number}
+#'   \item{station_group}{Geographic group the station belongs to}
+#' }
+#'
+#' @source selection.pm from HARMONIE / HIRLAM monitor
+"station_groups"

R/data_structures.R

@@ -186,22 +186,22 @@ print.harp_anl_xs_df <- function(x, ...) {
 #' @examples
 #' as_harp_list(
 #'   a = as_harp_df(data.frame(
-#'     valid_dttm = seq_dttm(2021010100, 2021010123),
+#'     valid_dttm = as_dttm(seq_dttm(2021010100, 2021010123)),
 #'     a_det = runif(24)
 #'   )),
 #'   b = as_harp_df(data.frame(
-#'     valid_dttm = seq_dttm(2021010100, 2021010123),
+#'     valid_dttm = as_dttm(seq_dttm(2021010100, 2021010123)),
 #'     b_det = runif(24)
 #'   ))
 #' )
 #' as_harp_list(
 #'   a = as_harp_df(data.frame(
-#'     valid_dttm = seq_dttm(2021010100, 2021010123),
+#'     valid_dttm = as_dttm(seq_dttm(2021010100, 2021010123)),
 #'     a_mbr000  = runif(24),
 #'     a_mbr001  = runif(24)
 #'   )),
 #'   b = as_harp_df(data.frame(
-#'     valid_dttm = seq_dttm(2021010100, 2021010123),
+#'     valid_dttm = as_dttm(seq_dttm(2021010100, 2021010123)),
 #'     b_mbr000 = runif(24),
 #'     b_mbr001 = runif(24)
 #'   ))
@@ -288,12 +288,14 @@ as_det.harp_ens_point_df <- function(x, member = NULL, sub_model = NULL) {
   }
 
   if (num_members == 1) {
-    return(as_harp_df(
-      dplyr::rename_with(x, ~"forecast", dplyr::matches("_mbr[[:digit:]]{3}"))
-    ))
+    if (is.null(member)) {
+      member <- sub(
+        "[[:graph:]]*_(?=mbr[[:digit:]]{3})", "", member_cols, perl = TRUE
+      )
+    }
   }
 
-  if (is.null(member)) {
+  if (is.null(member) && num_members > 1) {
     cli::cli_abort(c(
       "Must specify a member for enesmbles with more than 1 member:",
       "i" = "There {?is/are} are {num_members} member{?s} in {.arg x}.",
@@ -395,3 +397,76 @@ as_det.harp_list <- function(x, member = NULL, sub_model = NULL) {
   x[ens_df] <- lapply(x[ens_df], as_det, member, sub_model)
   x
 }
+
+# Print method for harp_verif
+#' @export
+print.harp_verif <- function(x, n = NULL, ...) {
+  invisible(
+    mapply(
+      function(x, y) {
+        cat(cli::col_green(paste0("::", y, ":: ")))
+        print(x, n = n)
+        cat("\n")
+      },
+      x, names(x)
+    )
+  )
+  parameter <- paste(Reduce(union, attr(x, "parameter")), collapse = ", ")
+  dttm <- Reduce(union, attr(x, "dttm"))
+  dttm_range <- format(
+    harpCore::as_dttm(range(dttm)),
+    "%R %Z %d %b %Y"
+  )
+  stations <- Reduce(union, attr(x, "stations"))
+  num_stations <- length(stations)
+  groupings <- attr(x, "group_vars")
+  if (!is.list(groupings)) {
+    groupings <- list(groupings)
+  }
+  if (all(vapply(groupings, is.list, logical(1)))) {
+    groupings <- purrr::flatten(groupings)
+  }
+  groupings <- lapply(
+    groupings,
+    function(g) g[vapply(g, nchar, integer(1)) > 0]
+  )
+  groupings <- groupings[vapply(groupings, length, integer(1)) > 0]
+  cat(
+    cli::col_cyan("--harp verification for "),
+    cli::col_magenta(parameter),
+    cli::col_cyan("--"),
+    sep = ""
+  )
+  cat(
+    "\n",
+    cli::col_cyan("# for forecasts from"),
+    cli::col_magenta(dttm_range[1]),
+    cli::col_cyan("to"),
+    cli::col_magenta(dttm_range[2])
+  )
+  if (num_stations > 0) {
+    cat(
+      "\n",
+      cli::col_cyan("# using"),
+      cli::col_magenta(num_stations),
+      cli::col_cyan("observation stations")
+    )
+  }
+  if (length(groupings) > 0) {
+    cat("\n", cli::col_cyan("# for verification groups: "))
+    invisible(
+      lapply(
+        groupings,
+        function(g) {
+          g <- glue::glue_collapse(g, sep = ", ", last = " & ")
+          cat("\n   ", cli::col_cyan("->"), cli::col_magenta(g))
+        }
+      )
+    )
+    cat("\n")
+    cli::cli_inform(c(
+      "i" = cli::col_silver("use `attributes()` to see detailed metadata")
+    ))
+  }
+
+}

R/date_time.R

@@ -39,12 +39,7 @@
 as_str_dttm <- function(x) {
   x <- as_YMDhms(x)
 
-  trailing_0s <- min(
-    sapply(
-      regmatches(x, gregexpr('\\(?[0]+', x)),
-      function(y) nchar(y[length(y)])
-    )
-  )
+  trailing_0s <- min(nchar(x) - nchar(sub("0*$", "", x)))
 
   if (!trailing_0s %% 2 == 0) {
     trailing_0s <- trailing_0s - 1