change outbreak to obr objects; add S3 creator function; remove N…

…A from `outbreak_status` variable

DESCRIPTION

@@ -25,7 +25,8 @@ Imports:
     ggplot2,
     ggpubr,
     reshape2,
-    plyr
+    plyr,
+    forcats
 Encoding: UTF-8
 LazyData: true
 RoxygenNote: 6.1.1

NAMESPACE

@@ -2,7 +2,9 @@
 
 S3method(plot,defol)
 export(as.defol)
+export(as.obr)
 export(as_defol)
+export(as_obr)
 export(defol)
 export(defol_stats)
 export(defoliate_trees)
@@ -11,7 +13,8 @@ export(get_defol_events)
 export(gsi)
 export(id_defoliation)
 export(is.defol)
-export(is.outbreak)
+export(is.obr)
+export(obr)
 export(outbreak)
 export(outbreak_stats)
 export(plot_defol)

R/main.R

@@ -2,38 +2,44 @@
 #'
 #' @param host_tree a data.frame rwl object containing the tree-level growth
 #'   series for all host trees to be compared to the non-host chronology
+#'
 #' @param nonhost_chron a data.frame rwl object comtaining a single non-host
 #'   chronology
+#'
 #' @param duration_years the mimimum number of years in which to consider a
 #'   defolation event
+#'
 #' @param max_reduction the minimum level of tree growth to be considered in
 #'   defoliation
-#'@param bridge_events Binary, defaults to \code{FALSE}. This option allows for
+#'
+#'@param bridge_events Binary, defaults to `FALSE`. This option allows for
 #'   two successive events separated by a single year to be bridged and called one
 #'   event. It should be used cautiously and closely evaluated to ensure the
 #'   likelihood that the two events are actually one long event.
-#' @param series_end_event Binary, defaults to \code{FALSE}. This option allows
+#'
+#' @param series_end_event Binary, defaults to `FALSE`. This option allows
 #'   the user to identify an event ocuring at the time of sampling as a
 #'   defoliation event, regardless of duration. Including it will help to
 #'   quantify periodicity and extent of an outbreak. This should only be used if
 #'   the user has direct knowledge of an ongoing defoliation event when the
 #'   trees were sampled.
-#' @param list_output defaults to \code{FALSE}. This option is to output a long
+#'
+#' @param list_output defaults to `FALSE`. This option is to output a long
 #'   list object containing a separate data.frame for each series in
-#'   \code{host_tree} that includes the input series and the
-#'   \code{nonhost_chron}, the corrected series, and the character string
+#'   `host_tree` that includes the input series and the
+#'   `nonhost_chron`, the corrected series, and the character string
 #'   identifying the defoliation events.
 #'
 #' @return By default this returns a long-form data frame of tree-level growth
-#'   suppression indices and identified defoliation events. If \code{list_output
-#'   = TRUE}, it returns a list object with each element containing a data.frame
+#'   suppression indices and identified defoliation events. If `list_output = TRUE`,
+#'   it returns a list object with each element containing a data.frame
 #'   rwl object of the host and non-host series, plus the outputs from
-#'   \code{gsi}. The list object is useful for assessing the effects of running
-#'   \code{gsi} on the host and nonhost data.
+#'   [gsi()]. The list object is useful for assessing the effects of running
+#'   [gsi()] on the host and nonhost data.
 #'
-#' @note Other functions in \code{dfoliatR}, like \code{outbreak} and
-#'   \code{plot_defol}, require a long-form data frame identifiable as a
-#'   \code{defol} object. Selecting \code{list_output = TRUE} will trigger
+#' @note Other functions in `dfoliatR``, like [outbreak()] and
+#'   [plot_defol()], require a long-form data frame identifiable as a
+#'   [defol()] object. Selecting `list_output = TRUE` will trigger
 #'   errors in running other functions.
 #'
 #' @export
@@ -76,17 +82,12 @@ defoliate_trees <- function(host_tree, nonhost_chron, duration_years = 8,
 #' @param filter_min_defol The minimum number of trees recording a defoliation
 #'   event. Default is 1 tree.
 #'
-#' @param force Ignores the class structure if the data frame, to aid in  batch
-#'   processing. Defaults to FALSE. Use cautiously.
 #'
 #' @importFrom rlang .data
 #'
 #' @export
-outbreak <- function(x, filter_perc = 25, filter_min_series = 3, filter_min_defol = 1,
-                     force = FALSE){
-  if(! force){
-    if(!is.defol(x)) stop("x must be a defol object")
-  }
+outbreak <- function(x, filter_perc = 25, filter_min_series = 3, filter_min_defol = 1) {
+  if (!is.defol(x)) stop("x must be a defol object")
   series_count <- sample_depth(x)
   defol_events <- c("defol", "max_defol", "bridge_defol", "series_end_defol")
   event_count <- as.data.frame(table(year = subset(x, x$defol_status %in% defol_events)$year))
@@ -106,6 +107,7 @@ outbreak <- function(x, filter_perc = 25, filter_min_series = 3, filter_min_defo
   event_years <- data.frame(year = comp_years,
                             outbreak_status = "outbreak")
   comp <- merge(counts, event_years, by = "year", all = TRUE)
+  comp$outbreak_status <- forcats::fct_explicit_na(comp$outbreak_status, na_level = "not_obr")
   series_cast_gsi <- reshape2::dcast(x, year ~ series, value.var = "gsi")
   series_cast_gsi$mean_gsi <- round(rowMeans(series_cast_gsi[, -1], na.rm=TRUE), 4)
   series_cast_norm <- reshape2::dcast(x, year ~ series, value.var = "ngsi")
@@ -115,6 +117,5 @@ outbreak <- function(x, filter_perc = 25, filter_min_series = 3, filter_min_defo
   out <- merge(comp, mean_series, by = "year")
   out <- dplyr::select(out, "year", "samp_depth", "num_defol", "perc_defol",  "num_max_defol",
                        "perc_max_defol", "mean_gsi", "mean_ngsi", "outbreak_status")
-  class(out) <- c("outbreak", "data.frame")
-  return(out)
+  as_obr(out)
 }

R/plotting.R

@@ -67,14 +67,14 @@ plot_defol <- function(x, breaks){
 #'
 #' @export
 plot_outbreak <- function(x, disp_index = "mean_ngsi"){
-  if(!is.outbreak(x)) stop("'x' must be an 'outbreak' object")
+  if(!is.obr(x)) stop("'x' must be an 'obr' object")
   if(! (disp_index == "mean_gsi" | disp_index == "mean_ngsi")) {
     # warning("Displaying the 'mean_ngsi'")
     disp_index <- "mean_ngsi"
   }
   if(disp_index == "mean_ngsi") y_intercept <- 0
   else y_intercept <- 1
-  outbrk_events <- x[! is.na(x$outbreak_status), ]
+  outbrk_events <- x[! x$outbreak_status %in% "not_obr", ]
 
   # setup plot
   p <- ggplot(data = x, aes(x = .data$year))

R/stats.R

@@ -91,7 +91,7 @@ get_defol_events <- function(x){
 #'
 #'@export
 outbreak_stats <- function(x){
-  if(!is.outbreak(x)) stop ("x must be an outbreak object")
+  if(!is.obr(x)) stop ("x must be an `obr` object")
   events <- rle(x$outbreak_status == "outbreak")
   events_index <- cumsum(events$lengths)
   events_pos <- which(events$values == TRUE)

R/utils.R

@@ -213,7 +213,7 @@ as_defol <- function(x) {
 #' @export
 as.defol <- function(x) {
   as_defol(x)
-  }
+}
 
 #' Stack a defoliation list
 #'
@@ -275,13 +275,111 @@ is.defol <- function(x) {
   inherits(x, 'defol')
 }
 
+#' Turn character vector into factor with proper levels of `outbreak_status`
+#'
+#' @param x a vector of outbreak designation types
+#'
+#' @return A factor with appropriate outbreak levels
+#'
+#' @noRd
+make_outbreak_status <- function(x){
+  obr_types <- c("outbreak", "not_obr")
+  stopifnot(x %in% obr_types)
+  factor(x, levels = obr_types)
+}
+
+#' Constructor for an `obr` object.
+#'
+#' @param year An n-length numeric vector of observed years.
+#'
+#' @param samp_depth An n-length numeric vector of the number of trees.
+#'
+#' @param num_defol An n-length numeric vector of the number of trees
+#'   experiencing defoliation.
+#'
+#' @param perc_defol An n-length numeric vector of the percent of trees
+#'   experiencing defoliation.
+#'
+#' @param num_max_defol An n-length numeric vector of the number of trees
+#'   experiencing their maximum level of defoliation (i.e., their most extreme
+#'   negative growth departure).
+#'
+#' @param perc_max_defol An n-length numeric vector of the percent of trees
+#'   experiencing their maximum level of defoliation (i.e., their most extreme
+#'   negative growth departure).
+#'
+#' @param mean_gsi An n-length numeric vector of the average growth suppression
+#'   index across all observed trees.
+#'
+#' @param mean_ngsi An n-length numeric vector of the average normalized
+#'   (scaled) growth suppression index.
+#'
+#' @param outbreak_status An n-length factor or character vector that identified
+#'   whether that year surpasses the designated thresholds for an "outbreak
+#'   event". Threshold criteria are provided in [outbreak()].
+#'
+#' @return An `obr` object with columns matching the input variables.
+#'
+#' @export
+obr <- function(year, samp_depth, num_defol, perc_defol, num_max_defol, perc_max_defol,
+                mean_gsi, mean_ngsi, outbreak_status) {
+  obr_dat <- data.frame(
+    year = as.numeric(year),
+    samp_depth = as.numeric(samp_depth),
+    num_defol = as.numeric(num_defol),
+    perc_defol = as.numeric(perc_defol),
+    num_max_defol = as.numeric(num_max_defol),
+    perc_max_defol = as.numeric(perc_max_defol),
+    mean_gsi = as.numeric(mean_gsi),
+    mean_ngsi = as.numeric(mean_ngsi),
+    outbreak_status = make_outbreak_status(outbreak_status)
+  )
+  class(obr_dat) <- c("obr", "data.frame")
+  obr_dat
+}
+
+#' Cast data frame to list-like to `obr` object
+#'
+#' @param x A data frame or list-like object to cast. Must have named elements
+#'   for "year", "samp_depth", "num_defol", "perc_defol", "num_max_defol", "perc_max_defol",
+#'   "mean_gsi", "mean_ngsi", "outbreak_status".
+#'
+#' @return `x` cast to an `obr` object
+#'
+#' @examples
+#' data(dmj_obr)
+#' example_data <- as.data.frame(dmj_obr)
+#' is.obr(example_data)
+#' back_to_obr <- as_obr(example_data)
+#' is.obr(back_to_obr)
+#'
+#' @export
+as_obr <- function(x) {
+  if (!all(c("year", "samp_depth", "num_defol", "perc_defol", "num_max_defol", "perc_max_defol",
+             "mean_gsi", "mean_ngsi", "outbreak_status") %in% names(x))) {
+    stop("`x` must have members 'year', 'samp_depth', 'num_defol', 'perc_defol', 'num_max_defol',
+          'perc_max_defol', 'mean_gsi', 'mean_ngsi', 'outbreak_status'")
+  }
+  obr(x$year, x$samp_depth, x$num_defol, x$perc_defol, x$num_max_defol, x$perc_max_defol,
+        x$mean_gsi, x$mean_ngsi, x$outbreak_status)
+}
+
+#' Alias to [as_obr()]
+#'
+#' @inherit as_obr
+#'
+#' @export
+as.obr <- function(x) {
+  as_obr(x)
+}
+
 #' Check if object is outbreak, meaning site-level outbreak object
 #'
 #' @param x Any R object.
 #'
 #' @return Boolean indicating whether `x` is an outbreak object.
 #'
 #' @export
-is.outbreak <- function(x) {
-  inherits(x, 'outbreak')
+is.obr <- function(x) {
+  inherits(x, 'obr')
 }