Merge pull request #367 from RobFryer/bug_366

ctsm_subset_assessment

NAMESPACE

@@ -21,7 +21,6 @@ export(ctsm_get_info)
 export(ctsm_read_determinand)
 export(ctsm_read_species)
 export(ctsm_read_thresholds)
-export(ctsm_subset_assessment)
 export(ctsm_summary_overview)
 export(ctsm_symbology_OSPAR)
 export(ctsm_uncrt_estimate)
@@ -42,6 +41,7 @@ export(plot_assessment)
 export(read_contaminants)
 export(read_data)
 export(run_assessment)
+export(subset_assessment)
 export(tidy_data)
 export(update_assessment)
 export(write_summary_table)

R/assessment_functions.R

@@ -87,7 +87,7 @@ run_assessment <- function(
 
 #' Update timeseries assessments
 #'
-#' Refits models for particular timeseries, or does fits new models when an
+#' Refits models for particular timeseries, or fits new models when an
 #' assessment is being done in chunks.
 #'
 #' @param ctsm_ob A HARSAT object resulting from a call to run_assessment

R/information_functions.R

@@ -2657,27 +2657,70 @@ get.info.imposex <- function(
 #' Get station code from station name
 #'
 #' Gets the station code corresponding to the station name and country from the 
-#' station dictionary. Only works for one country at a time
+#' station dictionary. 
 #'
 #' @param station_name
 #' @param country
 #' @param stations
 #' @export
 get_station_code <- function(station_name, country, stations) {
 
-  stopifnot(length(country) == 1)
   n <- length(station_name)
 
+  if (!(length(country) %in% c(1L, n))) {
+    stop(
+      "'country' must either be a single character or the same length as 'station_name'"
+    )  
+  }
+
   out <- data.frame(station_name = station_name, country = country) 
-  out <- mutate(out, across(.fns = as.character))
+
+  if (any(is.na(out))) {
+    stop("missing values not allowed in 'station_name' or 'country'")
+  }
 
-
+  id <- c("station_name", "country")
+  out <- dplyr::mutate(out, across(all_of(id), as.character))
+
+  id <- c("station_name", "country", "station_code")
   stations <- stations[c("station_name", "country", "station_code")]
-  stations <- mutate(stations, across(.fns = as.character)) 
+  stations <- dplyr::mutate(stations, across(all_of(id), as.character)) 
 
-  out <- dplyr::left_join(out, stations, by = c("station_name", "country"))
+  out <- dplyr::left_join(
+    out, 
+    stations, 
+    by = c("station_name", "country"), 
+    relationship = "many-to-many"
+  )
 
-  stopifnot(!is.na(out), n == nrow(out))
+  if (any(is.na(out$station_code))) {
+    out_error <- dplyr::filter(out, is.na(.data$station_code))
+    out_error <- paste(out_error$country, out_error$station_name)
+    warning(
+      "the following station_names are not recognised:\n", 
+      paste(out_error, collapse = "\n"), 
+      immediate. = TRUE
+    )
+  }
 
+  if (nrow(out) != n) {
+    out_error <- unique(out)
+    out_error <- tidyr::unite(
+      out_error, 
+      "id", 
+      all_of(c("country", "station_name")),
+      sep = " "
+    )
+    out_error <- dplyr::filter(
+      out_error, 
+      .data$id %in% .data$id[duplicated(.data$id)]
+    )
+    out_error <- paste(out_error$id, out_error$station_code)
+    stop(
+      "the following station_names match to multiple station_codes:\n", 
+      paste(out_error, collapse = "\n")
+    )
+  }
+
   out$station_code
 }

R/reporting_functions.R

@@ -57,37 +57,48 @@ ctsm.projection <- function(latitude, longitude) {
 
 # support functions ----
 
+#' Subsets an assessment object
+#' 
+#' Selects specific time series and simplifies the data, stations and 
+#' assessment components to match
+#'  
+#' @param assessment_obj An assessment object resulting from a call to
+#'   run_assessment.
+#' @param subset A vector specifying the timeseries to be retained. An
+#'   expression will be evaluated in the timeSeries component of assessment_obj; 
+#'   use 'series' to identify individual timeseries.
+#'
+#' @returns
+#.
 #' @export
-ctsm_subset_assessment <- function(assessment_obj, subset) {
+subset_assessment <- function(assessment_obj, subset) {
 
   # reporting_functions.R
   # subsets an assessment object by filtering on the timeSeries component
 
   timeSeries <- assessment_obj$timeSeries
 
+  timeSeries <- tibble::rownames_to_column(timeSeries, "series")
   ok <- eval(substitute(subset), timeSeries, parent.frame())
   timeSeries <- timeSeries[ok, ]
+  series_id <- timeSeries$series
+
+  row.names(timeSeries) <- NULL
+  timeSeries <- tibble::column_to_rownames(timeSeries, "series")
 
   assessment_obj$timeSeries <- timeSeries
 
 
   # update other components to be consistent
 
-  id <- row.names(timeSeries)
+  assessment_obj$assessment <- assessment_obj$assessment[series_id]
 
-  assessment_obj$assessment <- assessment_obj$assessment[id]
-
-  ok <- assessment_obj$data$seriesID %in% id
+  ok <- assessment_obj$data$seriesID %in% series_id
   assessment_obj$data <- assessment_obj$data[ok, ]
 
-  ok <- row.names(assessment_obj$stations) %in% timeSeries$station 
+  ok <- assessment_obj$stations$station_code %in% timeSeries$station_code 
   assessment_obj$stations <- assessment_obj$stations[ok, ]
-
-
-  # drop redundant factor levels
-
-  id <- c("timeSeries", "data", "stations")
-  assessment_obj[id] <- lapply(assessment_obj[id], droplevels)
+  row.names(assessment_obj$stations) <- NULL
 
   assessment_obj
 }