Skip to content

Commit

Permalink
linting
Browse files Browse the repository at this point in the history
  • Loading branch information
@chguiterman
chguiterman committed Jan 7, 2020
1 parent 5ff392f commit ede8dd2
Show file tree
Hide file tree
Showing 14 changed files with 355 additions and 258 deletions.
179 changes: 108 additions & 71 deletions R/main.R
View file
Original file line number Diff line number Diff line change
@@ -1,60 +1,63 @@
#' Identify defoliation events in host trees
#'
#' @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 `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 `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 `FALSE`. This option is to output a long
#' list object containing a separate data.frame for each series in
#' `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 `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
#' [gsi()]. The list object is useful for assessing the effects of running
#' [gsi()] on the host and nonhost data.
#'
#' @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.
#'Identify defoliation events in host trees
#'
#' @export
#'@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 `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 `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 `FALSE`. This option is to output a long list
#' object containing a separate data.frame for each series in `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 `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 [gsi()].
#' The list object is useful for assessing the effects of running [gsi()] on
#' the host and nonhost data.
#'
#'@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
defoliate_trees <- function(host_tree, nonhost_chron, duration_years = 8,
max_reduction = -1.28, bridge_events = FALSE,
series_end_event = FALSE, list_output = FALSE) {
if(ncol(nonhost_chron) > 1) stop("nonhost_chron can only contain 1 series")
if(max_reduction > 0) max_reduction <- max_reduction * -1
# To DO: Add provision that if only host series are given, no correction is made, but series are scanned for defol_status
if (ncol(nonhost_chron) > 1) stop("nonhost_chron can only contain 1 series")
if (max_reduction > 0) max_reduction <- max_reduction * -1
# To DO: Add provision that if only host series are given, no correction is
# made, but series are scanned for defol_status
host_tree <- data.frame(host_tree)
nonhost_chron <- data.frame(nonhost_chron)
nseries <- ncol(host_tree)
tree_list <- lapply(seq_len(nseries), function(i){
input_series <- stats::na.omit(dplR::combine.rwl(host_tree[, i, drop=FALSE],
nonhost_chron))
tree_list <- lapply(seq_len(nseries), function(i) {
input_series <-
stats::na.omit(
dplR::combine.rwl(
host_tree[, i, drop = FALSE],
nonhost_chron)
)
corrected_series <- gsi(input_series)
defoliated_series <- id_defoliation(corrected_series,
duration_years = duration_years,
Expand Down Expand Up @@ -86,36 +89,70 @@ defoliate_trees <- function(host_tree, nonhost_chron, duration_years = 8,
#' @importFrom rlang .data
#'
#' @export
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")
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))
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)
)
event_count$year <- as.numeric(as.character(event_count$year))
max_count <- as.data.frame(table(year = subset(x, x$defol_status == "max_defol")$year))
max_count <-
as.data.frame(
table(year = subset(x, x$defol_status == "max_defol")$year)
)
max_count$year <- as.numeric(as.character(max_count$year))
defol_counts <- merge(event_count, max_count, by = 'year', all=TRUE)
names(defol_counts) <- c('year', 'num_defol', 'num_max_defol')
counts <- merge(series_count, defol_counts, by = 'year', all=TRUE)
counts <- dplyr::mutate(counts,
num_defol = replace(.data$num_defol, is.na(.data$num_defol), 0),
num_max_defol = replace(.data$num_max_defol, is.na(.data$num_max_defol), 0),
perc_defol = round(.data$num_defol / .data$samp_depth * 100, 1),
perc_max_defol = round(.data$num_max_defol / .data$samp_depth *100, 1))
filter_mask <- (counts$perc_defol >= filter_perc) & (counts$samp_depth >= filter_min_series) & (counts$num_defol >= filter_min_defol)
defol_counts <-
merge(event_count, max_count, by = "year", all = TRUE)
names(defol_counts) <- c("year", "num_defol", "num_max_defol")
counts <- merge(series_count, defol_counts, by = "year", all = TRUE)
counts <- dplyr::mutate(
counts,
num_defol = replace(.data$num_defol, is.na(.data$num_defol), 0),
num_max_defol = replace(.data$num_max_defol, is.na(.data$num_max_defol), 0),
perc_defol = round(.data$num_defol / .data$samp_depth * 100, 1),
perc_max_defol = round(.data$num_max_defol / .data$samp_depth *
100, 1)
)
filter_mask <-
(counts$perc_defol >= filter_perc) &
(counts$samp_depth >= filter_min_series) &
(counts$num_defol >= filter_min_defol)
comp_years <- subset(counts, filter_mask)$year
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")
series_cast_norm$mean_ngsi <- round(rowMeans(series_cast_norm[, -1], na.rm=TRUE), 4)
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")
series_cast_norm$mean_ngsi <-
round(rowMeans(series_cast_norm[, -1], na.rm = TRUE), 4)
mean_series <- merge(series_cast_gsi[, c("year", "mean_gsi")],
series_cast_norm[, c("year", "mean_ngsi")])
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")
out <-
dplyr::select(
out,
"year",
"samp_depth",
"num_defol",
"perc_defol",
"num_max_defol",
"perc_max_defol",
"mean_gsi",
"mean_ngsi",
"outbreak_status"
)
as_obr(out)
}
53 changes: 29 additions & 24 deletions R/plotting.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,34 +10,39 @@
#' @importFrom ggplot2 ggplot aes geom_segment theme_bw theme element_blank
#'
#' @export
plot_defol <- function(x, breaks){
plot_defol <- function(x, breaks) {
stopifnot(is.defol(x))
s.stats <- defol_stats(x)
e.stats <- get_defol_events(x)
if(! missing(breaks)){
s_stats <- defol_stats(x)
e_stats <- get_defol_events(x)
if (! missing(breaks)) {
break_vals <- breaks
}
else break_vals <- summary(e.stats$ngsi_mean)[c(2, 4)]
e.stats$Severity <- cut(e.stats$ngsi_mean,
breaks = c(-Inf, break_vals[[1]], break_vals[[2]], Inf),
else break_vals <- summary(e_stats$ngsi_mean)[c(2, 4)]
e_stats$Severity <- cut(e_stats$ngsi_mean,
breaks = c(-Inf,
break_vals[[1]],
break_vals[[2]],
Inf),
right = FALSE,
labels = c("Severe", "Moderate", "Minor"))
labels = c("Severe",
"Moderate",
"Minor"))
# plot object formation
p <- ggplot(x, aes(x = .data$year, y = .data$series))
p <- p + geom_segment(data = s.stats,
p <- p + geom_segment(data = s_stats,
aes(x = .data$first,
xend = .data$last,
y = .data$series,
yend = .data$series),
linetype = 'dotted')
p <- p + geom_segment(data = e.stats,
linetype = "dotted")
p <- p + geom_segment(data = e_stats,
aes(x = .data$start_year,
xend = .data$end_year,
y = .data$series,
yend = .data$series,
colour = .data$Severity),
linetype = 'solid',
size=1.25)
linetype = "solid",
size = 1.25)
p <- p + theme_bw() +
theme(
panel.grid.major.y = element_blank(),
Expand Down Expand Up @@ -66,32 +71,32 @@ plot_defol <- function(x, breaks){
#' geom_ribbon unit
#'
#' @export
plot_outbreak <- function(x, disp_index = "mean_ngsi"){
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'")
plot_outbreak <- function(x, disp_index = "mean_ngsi") {
if (!is.obr(x)) stop("'x' must be an 'obr' object")
if (! (disp_index == "mean_gsi" | disp_index == "mean_ngsi")) {
disp_index <- "mean_ngsi"
}
if(disp_index == "mean_ngsi") y_intercept <- 0
if (disp_index == "mean_ngsi") y_intercept <- 0
else y_intercept <- 1
outbrk_events <- x[! x$outbreak_status %in% "not_obr", ]

# setup plot
p <- ggplot(data = x, aes(x = .data$year))
# extract minor axes
foo <- p + geom_line(aes(y = .data[[disp_index]]))
minor_labs <- ggplot2::ggplot_build(foo)$layout$panel_params[[1]]$x.minor_source
minor_labs <-
ggplot2::ggplot_build(foo)$layout$panel_params[[1]]$x.minor_source
# top plot
index <- p +
geom_vline(xintercept = minor_labs, colour="grey50") +
geom_vline(xintercept = minor_labs, colour = "grey50") +
geom_hline(yintercept = y_intercept, colour = "grey80") +
geom_line(aes(y = .data[[disp_index]])) +
geom_segment(data = outbrk_events,
aes(x = .data$year,
xend = .data$year,
y = y_intercept,
yend = .data[[disp_index]]),
size=2) +
size = 2) +
scale_y_continuous(name = "Growth suppression index") +
ggpubr::theme_pubr() +
theme(plot.margin = unit(c(0.1, 0, 0, 0), "cm"),
Expand All @@ -110,21 +115,21 @@ plot_outbreak <- function(x, disp_index = "mean_ngsi"){
axis.ticks.x = element_blank())
# bottom plot
line <- p +
geom_vline(xintercept = minor_labs, colour="grey50") +
geom_vline(xintercept = minor_labs, colour = "grey50") +
geom_line(aes(y = .data$samp_depth)) +
scale_y_continuous(name = "Sample depth") +
scale_x_continuous(name = "Year") +
ggpubr::theme_pubr() +
theme(plot.margin = unit(c(0.1, 0, 0, 0), "cm"))
# combine
ggpubr::ggarrange(index, prop, line, nrow=3, align = "v")
ggpubr::ggarrange(index, prop, line, nrow = 3, align = "v")
}

#' Plot a \code{defol} object
#'
#' @param ... arguments passed to \code{plot_defol}
#'
#' @export
plot.defol <- function(...){
plot.defol <- function(...) {
print(plot_defol(...))
}

0 comments on commit ede8dd2

Please sign in to comment.