diff --git a/DESCRIPTION b/DESCRIPTION index 78fa90e..e80e885 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,60 +2,25 @@ Package: PacFIN.Utilities Title: Generate fishery composition data from PacFIN data for the NWFSC Version: 0.2.9 Authors@R: c( - person( - given = c("Kelli", "F."), - family = "Johnson", - role = c("aut", "cre"), - email = "kelli.johnson@noaa.gov", - comment = c(ORCID = "0000-0002-5149-451X") - ), - person( - given = c("Chantel", "R."), - family = "Wetzel", - role = "aut", - email = "chantel.wetzel@noaa.gov", - comment = c(ORCID = "0000-0002-7573-8240") - ), - person( - given = c("Kathryn", "L."), - family = "Doering", - role = "ctb", - email = "kathryn.doering@noaa.gov", - comment = c(ORCID = "0000-0002-0396-7044") - ), - person( - given = c("Brian", "J."), - family = "Langseth", - role = "ctb", - email = "brian.langseth@noaa.gov", - comment = c(ORCID = "0000-0002-9901-6146") - ), - person( - given = "Andi", - family = "Stephens", - role = "ctb", - email = "andi.stephens@noaa.gov" - ), - person( - given = c("Ian", "G."), - family = "Taylor", - role = "ctb", - email = "ian.taylor@noaa.gov", - comment = c(ORCID = "0000-0002-4232-5669") - ), - person( - given = c("John", "R."), - family = "Wallace", - role = "ctb", - email = "john.wallace@noaa.gov", - comment = c(ORCID = "0000-0002-2333-1262") - ) - ) -Description: Manipulates data from the PacFIN database for stock synthesis. + person(c("Kelli", "F."), "Johnson", , "kelli.johnson@noaa.gov", role = c("aut", "cre"), + comment = c(ORCID = "0000-0002-5149-451X")), + person(c("Chantel", "R."), "Wetzel", , "chantel.wetzel@noaa.gov", role = "aut", + comment = c(ORCID = "0000-0002-7573-8240")), + person(c("Kathryn", "L."), "Doering", , "kathryn.doering@noaa.gov", role = "ctb", + comment = c(ORCID = "0000-0002-0396-7044")), + person(c("Brian", "J."), "Langseth", , "brian.langseth@noaa.gov", role = "ctb", + comment = c(ORCID = "0000-0002-9901-6146")), + person("Andi", "Stephens", , "andi.stephens@noaa.gov", role = "ctb"), + person(c("Ian", "G."), "Taylor", , "ian.taylor@noaa.gov", role = "ctb", + comment = c(ORCID = "0000-0002-4232-5669")), + person(c("John", "R."), "Wallace", , "john.wallace@noaa.gov", role = "ctb", + comment = c(ORCID = "0000-0002-2333-1262")) + ) +Description: Manipulates data from the PacFIN database for stock + synthesis. +License: MIT + file LICENSE Depends: R (>= 4.2) -License: MIT + file LICENSE -LazyData: true Imports: cli, dplyr, @@ -81,10 +46,12 @@ Suggests: RODBC, testthat (>= 3.0.0), usethis +VignetteBuilder: + knitr Remotes: - github::pfmc-assessments/nwfscSurvey -VignetteBuilder: knitr -Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 -Encoding: UTF-8 + github::pfmc-assessments/nwfscSurvey Config/testthat/edition: 3 +Encoding: UTF-8 +LazyData: true +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.3.2 diff --git a/R/EF1_Denominator.R b/R/EF1_Denominator.R index 031165b..4a794e9 100644 --- a/R/EF1_Denominator.R +++ b/R/EF1_Denominator.R @@ -12,7 +12,7 @@ #' For a survey, tow- or haul-level data are typically available. #' The sum of the weight in the sample is calculated different for each state #' based on the data that are available. -#' +#' #' Oregon provides information on the weight of females and males in the sample #' via the `WEIGHT_OF_FEMALES` and `WEIGHT_OF_MALES` columns. These are often #' model-based weights, which would be the only way they can get weights when @@ -20,7 +20,7 @@ #' internally by the code and added to the female and male weight. #' **todo**: Let Oregon know that this calculation is being done and they may want #' to provide UNK_WGT. -#' +#' #' California sample weights were previously based on the column labeled #' `SPECIES_WEIGHT`. Now, California data is parsed by PacFIN to furnish #' species-specific cluster weights. Prior, cluster weights included the weight @@ -59,7 +59,7 @@ #' * `Wt_Sampled_1`: the sum of sex-specific weights within the sample. #' * `Wt_Sampled_2`: the species-specific sample weight only provided by #' California in cluster weight. -#' * `LW_Calc_Wt`: individual weights predicted from the specified +#' * `LW_Calc_Wt`: individual weights predicted from the specified #' length-weight relationships. #' * `Wt_Sampled_3`: The sum of empirical weights, for those fish within a #' sample where this information is available, and weights calculated from the @@ -79,12 +79,13 @@ EF1_Denominator <- function(Pdata, verbose = TRUE, plot = FALSE, col.weight = "weightkg") { - if (verbose) { cat("\nIndividual weights will be generated from the following values:\n\n") - cat(" Females:", fa,fb, "\n", - "Males:", ma,mb, "\n", - "Unknowns and hermaphrodites:", ua,ub, "\n\n") + cat( + " Females:", fa, fb, "\n", + "Males:", ma, mb, "\n", + "Unknowns and hermaphrodites:", ua, ub, "\n\n" + ) } # End if verbose stopifnotcolumn(Pdata, col.weight) @@ -95,65 +96,74 @@ EF1_Denominator <- function(Pdata, sex = Pdata$SEX, pars = data.frame( "A" = c("females" = fa, "males" = ma, "all" = ua), - "B" = c("females" = fb, "males" = mb, "all" = ub)), + "B" = c("females" = fb, "males" = mb, "all" = ub) + ), unit.out = "lb" - ) + ) #### Calculate sample weight using FISH_WEIGHT in lbs Pdata <- Pdata %>% - # Use weightkg if available and calculated from WL relationship when NA - # Note the change in units for weightkg from KG to LBS - dplyr::mutate( - bestweight = dplyr::case_when( - is.na(weightkg) ~ LW_Calc_Wt, - TRUE ~ weightkg * 2.20462) + # Use weightkg if available and calculated from WL relationship when NA + # Note the change in units for weightkg from KG to LBS + dplyr::mutate( + bestweight = dplyr::case_when( + is.na(weightkg) ~ LW_Calc_Wt, + TRUE ~ weightkg * 2.20462 + ) ) %>% - # Group by SAMPLE_NO so all subsequent calculations are done on subsets - # of the data, i.e., mean(bestweight) is mean of the bestweight in a - # specific sample - dplyr::group_by(SAMPLE_NO) %>% - dplyr::mutate( - bestweight = ifelse( - is.na(bestweight), - mean(bestweight), - bestweight) + # Group by SAMPLE_NO so all subsequent calculations are done on subsets + # of the data, i.e., mean(bestweight) is mean of the bestweight in a + # specific sample + dplyr::group_by(SAMPLE_NO) %>% + dplyr::mutate( + bestweight = ifelse( + is.na(bestweight), + mean(bestweight), + bestweight + ) + ) %>% + # Calculate sample weights and weight of unsexed fish per SAMPLE_NO + dplyr::mutate( + Wt_Sampled_3_L = sum( + na.rm = TRUE, + ifelse(is.na(length), NA, bestweight) + ), + Wt_Sampled_3_A = sum( + na.rm = TRUE, + ifelse(is.na(Age), NA, bestweight) + ), + UNK_WT = sum(ifelse(SEX == "U", bestweight, 0)), + UNK_NUM = sum(SEX == "U") + ) %>% + # Back out the weight of fish that have no length or Age for each + # specific sample weight, if all are NA in sample, then set to 0. + dplyr::mutate( + Wt_Sampled_1_A = (-1 * sum(ifelse(is.na(Age), bestweight, 0)) + + FEMALES_WGT + MALES_WGT + UNK_WT) * + ifelse(all(is.na(Age)), 0, 1), + Wt_Sampled_1_L = (-1 * sum(ifelse(is.na(length), bestweight, 0)) + + FEMALES_WGT + MALES_WGT + UNK_WT) * + ifelse(all(is.na(length)), 0, 1) ) %>% - # Calculate sample weights and weight of unsexed fish per SAMPLE_NO - dplyr::mutate( - Wt_Sampled_3_L = sum(na.rm = TRUE, - ifelse(is.na(length), NA, bestweight)), - Wt_Sampled_3_A = sum(na.rm = TRUE, - ifelse(is.na(Age), NA, bestweight)), - UNK_WT = sum(ifelse(SEX == "U", bestweight, 0)), - UNK_NUM = sum(SEX == "U") + dplyr::ungroup() %>% + dplyr::group_by(SAMPLE_NO, CLUSTER_NO) %>% + # Do the same for CLUSTER_WGT + dplyr::mutate( + Wt_Sampled_2_A = (-1 * sum(ifelse(is.na(Age), bestweight, 0)) + + CLUSTER_WGT) * ifelse(all(is.na(Age)), 0, 1), + Wt_Sampled_2_L = (-1 * sum(ifelse(is.na(length), bestweight, 0)) + + CLUSTER_WGT) * ifelse(all(is.na(length)), 0, 1) ) %>% - # Back out the weight of fish that have no length or Age for each - # specific sample weight, if all are NA in sample, then set to 0. - dplyr::mutate( - Wt_Sampled_1_A = (-1 * sum(ifelse(is.na(Age), bestweight, 0)) + - FEMALES_WGT + MALES_WGT + UNK_WT) * - ifelse(all(is.na(Age)), 0, 1), - Wt_Sampled_1_L = (-1 * sum(ifelse(is.na(length), bestweight, 0)) + - FEMALES_WGT + MALES_WGT + UNK_WT) * - ifelse(all(is.na(length)), 0, 1) - ) %>% dplyr::ungroup() %>% dplyr::group_by(SAMPLE_NO, CLUSTER_NO) %>% - # Do the same for CLUSTER_WGT - dplyr::mutate( - Wt_Sampled_2_A = (-1 * sum(ifelse(is.na(Age), bestweight, 0)) + - CLUSTER_WGT) * ifelse(all(is.na(Age)), 0, 1), - Wt_Sampled_2_L = (-1 * sum(ifelse(is.na(length), bestweight, 0)) + - CLUSTER_WGT) * ifelse(all(is.na(length)), 0, 1) - ) %>% - # Bring the calculations back to the full scale of the data frame - dplyr::ungroup() %>% - # Coalesce sets things to downstream values, only if NA, i.e., - # Wt_Sampled_[AL] is set by priority left to right 1, 2, 3 - dplyr::mutate( - Wt_Sampled_A = dplyr::coalesce(Wt_Sampled_1_A, Wt_Sampled_2_A, Wt_Sampled_3_A), - Wt_Sampled_L = dplyr::coalesce(Wt_Sampled_1_L, Wt_Sampled_2_L, Wt_Sampled_3_L) + # Bring the calculations back to the full scale of the data frame + dplyr::ungroup() %>% + # Coalesce sets things to downstream values, only if NA, i.e., + # Wt_Sampled_[AL] is set by priority left to right 1, 2, 3 + dplyr::mutate( + Wt_Sampled_A = dplyr::coalesce(Wt_Sampled_1_A, Wt_Sampled_2_A, Wt_Sampled_3_A), + Wt_Sampled_L = dplyr::coalesce(Wt_Sampled_1_L, Wt_Sampled_2_L, Wt_Sampled_3_L) ) %>% - # Return a data frame rather than a tibble - data.frame + # Return a data frame rather than a tibble + data.frame() #### Summary and boxplot # todo: revamp the summary and plots @@ -162,7 +172,7 @@ EF1_Denominator <- function(Pdata, Pdata$Wt_Sampled_3_L, Pdata$Wt_Sampled_L )) - names(printemp) = c("M+F+U","Cluster","L-W","Final Wt_Sampled") + names(printemp) <- c("M+F+U", "Cluster", "L-W", "Final Wt_Sampled") if (verbose) { cat("\nSample weights\n\n") @@ -200,13 +210,16 @@ EF1_Denominator <- function(Pdata, args.legend = list(x = "topleft", bty = "n") ) } - gg <- plotWL(Pdata[,"lengthcm"], Pdata[, "SEX"], Pdata[, "weightkg"], - Pdata[, "LW_Calc_Wt"] * 0.453592) - ggplot2::ggsave(gg, file = plot2, - width = 6, height = 6, units = "in") + gg <- plotWL( + Pdata[, "lengthcm"], Pdata[, "SEX"], Pdata[, "weightkg"], + Pdata[, "LW_Calc_Wt"] * 0.453592 + ) + ggplot2::ggsave(gg, + file = plot2, + width = 6, height = 6, units = "in" + ) } if (nNA == 0 & verbose) cat("\nSample Wts found for all samples.\n\n") return(Pdata) - } # End EF1_Denominator diff --git a/R/EF1_Numerator.R b/R/EF1_Numerator.R index dc0a617..074993d 100644 --- a/R/EF1_Numerator.R +++ b/R/EF1_Numerator.R @@ -1,5 +1,5 @@ #' Calculate the numerator for the first level expansion factor -#' +#' #' Calculate the numerator for the first-level expansion factor, where #' the numerator is the species-specific landing weight for a given sample. #' Thus, if two clusters were sampled from a single trip, @@ -12,7 +12,7 @@ #' For Washington, `Pdata$RWT_LBS`, `Pdata$TOTAL_WGT`, `RWT_LBS`, or #' `median(Pdata$TOTAL_WGT)`. #' Then, if all else failed, per-year, state-specific medians. -#' +#' #' Now, PacFIN works hard behind the scenes to provide species-specific landing #' weights for each sampled fish. Therefore, we no longer rely on code to #' calculate a fabricated landing weight. Species-specific landing weights are @@ -33,14 +33,14 @@ #' @template plot #' @author Andi Stephens -EF1_Numerator = function(Pdata, - verbose = TRUE, - plot = FALSE) { - +EF1_Numerator <- function(Pdata, + verbose = TRUE, + plot = FALSE) { Pdata$Trip_Sampled_Lbs <- dplyr::coalesce( - Pdata[["EXP_WT"]], Pdata[["RWT_LBS"]]) + Pdata[["EXP_WT"]], Pdata[["RWT_LBS"]] + ) - if (verbose){ + if (verbose) { cat("\nSampled pounds per trip:\n\n") print(summary(Pdata$Trip_Sampled_Lbs)) } @@ -48,14 +48,17 @@ EF1_Numerator = function(Pdata, if (plot != FALSE) { numstate <- length(unique(Pdata$state)) if (is.character(plot)) grDevices::png(plot) - graphics::par(mgp = c(2.5, 0.5, 0), mfrow = c(numstate, 1), mar = rep(0, 4), - oma = c(4, 5, 3, 0.5)) + graphics::par( + mgp = c(2.5, 0.5, 0), mfrow = c(numstate, 1), mar = rep(0, 4), + oma = c(4, 5, 3, 0.5) + ) for (st in unique(Pdata$state)) { plotdata <- Pdata[Pdata[, "state"] == st & !is.na(Pdata[["Trip_Sampled_Lbs"]]), ] if (all(is.na(plotdata$Trip_Sampled_Lbs))) next graphics::boxplot(plotdata$Trip_Sampled_Lbs ~ plotdata$fishyr, ylab = "", xlab = "", xaxt = "n", - at = unique(plotdata$fishyr), xlim = range(Pdata$fishyr)) + at = unique(plotdata$fishyr), xlim = range(Pdata$fishyr) + ) graphics::legend("topleft", legend = st, bty = "n") } graphics::axis(1) @@ -67,6 +70,4 @@ EF1_Numerator = function(Pdata, } return(Pdata) - } # End function EF1_Numerator - diff --git a/R/PacFIN.Utilities.R b/R/PacFIN.Utilities.R index 6e17691..4d992a4 100644 --- a/R/PacFIN.Utilities.R +++ b/R/PacFIN.Utilities.R @@ -1,21 +1,21 @@ #' PacFIN.Utilities: Functions for working up PacFIN data #' -#' The PacFIN.Utilities package provides functions for filtering, summarizing, expanding, and compiling +#' The PacFIN.Utilities package provides functions for filtering, summarizing, expanding, and compiling #' composition data, and writing out the final products: #' * length- #' * age- and #' * age-at-length compositions. -#' -#' Many of the functions described below write summary output to the console, and several create plots for +#' +#' Many of the functions described below write summary output to the console, and several create plots for #' visualizing data at various steps in processing. The information written to the console #' can be captured using the [sink] function to encapsulate your workflow: -#' +#' #' `sink("myfilename.txt", split=TRUE)` -#' +#' #' ... do work ... -#' +#' #' `sink()` -#' +#' #' The second call closes the file. #' #' @section Filtering functions: @@ -29,7 +29,7 @@ #' In addition, the [getExpansion_1] function has a "plot" argument to create #' plots documenting the expansions it creates. It also writes summary output to the #' console. -#' +#' #' @section Optional functions: #' [getSeason] For treating data from seasonal fisheries, such as Petrale. #' @@ -38,16 +38,16 @@ #' #' [getExpansion_2] computes the expansion values from the tow upwards to a #' user-specified stratification -#' +#' #' @section Expansion caveats: #' There is one manual step in the workflow. -#' After running the expansion functions, data columns Expansion_Factor_1 and -#' Expansion_Factor_2 are available to use in manually setting the Final_Expansion_Factor. +#' After running the expansion functions, data columns Expansion_Factor_1 and +#' Expansion_Factor_2 are available to use in manually setting the Final_Expansion_Factor. #' * Age data are expanded separately from lengths #' * WA fish are generally only expanded using Expansion_Factor_2. #' * Other expansions are the product of Expansion_Factor_1 * Expansion_Factor_2 #' * For age-at-length comps, set Final_Expansion_Factor to 1. Each fish represents only itself. -#' +#' #' @section Composition functions: #' [getComps] uses the column specified in `weightid` and the user-specified #' stratification to create comps. diff --git a/R/PullBDS.PacFIN.R b/R/PullBDS.PacFIN.R index 175430a..022197d 100644 --- a/R/PullBDS.PacFIN.R +++ b/R/PullBDS.PacFIN.R @@ -90,8 +90,8 @@ PullBDS.PacFIN <- function(pacfin_species_code, # Input checks stopifnot( "`verbose` must be a logical." = - is.logical(verbose) && - length(verbose) == 1 + is.logical(verbose) && + length(verbose) == 1 ) file_species_code <- paste(pacfin_species_code, collapse = "--") @@ -271,7 +271,8 @@ PullBDS.PacFIN <- function(pacfin_species_code, } # Save appropriate summaries - savefn <- file.path(savedir, + savefn <- file.path( + savedir, paste( sep = ".", "PacFIN", diff --git a/R/PullCatch.PacFIN.R b/R/PullCatch.PacFIN.R index fb51b87..4fb2f76 100644 --- a/R/PullCatch.PacFIN.R +++ b/R/PullCatch.PacFIN.R @@ -83,13 +83,13 @@ PullCatch.PacFIN <- function(pacfin_species_code, # Input checks stopifnot( "`addnominal` must be a logical." = - is.logical(addnominal) && - length(addnominal) == 1 + is.logical(addnominal) && + length(addnominal) == 1 ) stopifnot( "`verbose` must be a logical." = - is.logical(verbose) && - length(verbose) == 1 + is.logical(verbose) && + length(verbose) == 1 ) file_species_code <- paste(pacfin_species_code, collapse = "--") diff --git a/R/PullNominal.PacFIN.R b/R/PullNominal.PacFIN.R index d4320f8..f066a32 100644 --- a/R/PullNominal.PacFIN.R +++ b/R/PullNominal.PacFIN.R @@ -14,20 +14,20 @@ PullNominal.PacFIN <- function(pacfin_species_code, username = getUserName("PacFIN"), password = ask_password()) { - spp <- getDB( sql_species(), username = username, password = password ) - nom <- spp[grepl("NOM\\.", spp[,2]), ] %>% + nom <- spp[grepl("NOM\\.", spp[, 2]), ] %>% # Fix a known spelling mistake dplyr::mutate( PACFIN_SPECIES_COMMON_NAME = gsub( "VERMILLION", "VERMILION", - PACFIN_SPECIES_COMMON_NAME) + PACFIN_SPECIES_COMMON_NAME + ) ) out <- tibble::tibble(spp) %>% @@ -35,26 +35,30 @@ PullNominal.PacFIN <- function(pacfin_species_code, "BLACK AND YELLOW", "BLACK-AND-YELLOW", PACFIN_SPECIES_COMMON_NAME - )) %>% + )) %>% dplyr::mutate(searchname = gsub( "CALIFORNIA HALIBUT", "CALIF HALIBUT", searchname - )) %>% + )) %>% dplyr::mutate(searchname = gsub( "PACIFIC OCEAN PERCH", "POP", searchname - )) %>% + )) %>% dplyr::mutate(searchname = gsub( "(CHILIPEPPER|SQUARESPOT|VERMILION) ROCKFISH", "\\1", searchname - )) %>% - dplyr::mutate(nominal = purrr::map_chr(searchname, - ~paste0(grep(.x, nom[, 2], value = TRUE), collapse = "|"))) %>% - dplyr::mutate(code = purrr::map(nominal, ~{ - if (.x[1] == "") return(NA) + )) %>% + dplyr::mutate(nominal = purrr::map_chr( + searchname, + ~ paste0(grep(.x, nom[, 2], value = TRUE), collapse = "|") + )) %>% + dplyr::mutate(code = purrr::map(nominal, ~ { + if (.x[1] == "") { + return(NA) + } return(nom[grep(.x, nom[, 2]), 1]) })) %>% dplyr::filter(PACFIN_SPECIES_CODE %in% pacfin_species_code) %>% @@ -67,5 +71,4 @@ PullNominal.PacFIN <- function(pacfin_species_code, } return(out) - } diff --git a/R/age_representativeness_plot.R b/R/age_representativeness_plot.R index ec077e9..01e47f5 100644 --- a/R/age_representativeness_plot.R +++ b/R/age_representativeness_plot.R @@ -18,13 +18,13 @@ #' @param wait2plot A logical specifying if you want R to ask you to confirm #' page changes between plots. The default is \code{FALSE} and it will also #' be \code{FALSE} if plots are saved to the disk. -#' +#' #' @details -#' Output on figures include K-S p-value, which is the p-value output from -#' \code{\link{ks.test}} and is colored red if <.05 and green if >=.05, and -#' \code{expression(hat(b))}, which is the bhattacharyya coefficient calculated +#' Output on figures include K-S p-value, which is the p-value output from +#' \code{\link{ks.test}} and is colored red if <.05 and green if >=.05, and +#' \code{expression(hat(b))}, which is the bhattacharyya coefficient calculated #' as \code{sum(sqrt(pi1*pi2))} where pi1 and pi2 are the proportion of data in -#' bin i for each of the two distributions. +#' bin i for each of the two distributions. #' #' @return #' Several plots, potentially, are printed to the screen or saved to the disk diff --git a/R/capValues.R b/R/capValues.R index f6c869f..9807c4f 100644 --- a/R/capValues.R +++ b/R/capValues.R @@ -4,56 +4,50 @@ #' #' \code{capValues} takes a numeric vector and returns a vector in which all #' values greater than a specified maximum are reset to that maximum -#' value. -#' -#' +#' value. +#' +#' #' @export #' #' @details The maximum may be specified either as a -#' quantile or as a number. -#' +#' quantile or as a number. +#' #' If \code{maxVal} is less than one, it is #' interpreted as a quantile, otherwise it is interpreted as the maximum -#' value to return. -#' +#' value to return. +#' #' The default value is \code{0.95}, which caps all #' values in the input at the 95 percent quantile. -#' +#' #' #' @param DataCol A vector of numeric values. #' @param maxVal A numeric value specifying the maximum value or quantile -#' at which to cap all data. +#' at which to cap all data. #' @return A vector of numeric values where no value is greater than the #' maximum specified by \code{maxVal}. -#' +#' #' @section Example: -#' -#' x = seq(1,10) -#' y <- capValues(x, 0.75) -#' z <- capValues(x, 5) -#' rbind(x, y, z) +#' +#' x = seq(1,10) +#' y <- capValues(x, 0.75) +#' z <- capValues(x, 5) +#' rbind(x, y, z) #' #' @author Andi Stephens -#' +#' ########################################################################### capValues <- function(DataCol, maxVal = 0.95) { - - if ( maxVal > 1 ) { - - max.val = maxVal + if (maxVal > 1) { + max.val <- maxVal cat("\nMaximum value capped at", max.val, "\n\n") - } else { - - max.val = stats::quantile(DataCol, maxVal, na.rm=T) + max.val <- stats::quantile(DataCol, maxVal, na.rm = T) cat("\nMaximum expansion capped at", maxVal, "quantile:", max.val, "\n\n") - } # End if-else - DataCol[DataCol > max.val] = max.val + DataCol[DataCol > max.val] <- max.val return(DataCol) - } # End function capValues diff --git a/R/checkGrades.R b/R/checkGrades.R index 74e7365..ddab23d 100644 --- a/R/checkGrades.R +++ b/R/checkGrades.R @@ -1,15 +1,18 @@ #' Check Sample Numbers for Grade #' #' Ensure that each sample number has only one grade of fish in it. -#' +#' #' @template Pdata -#' +#' #' @author Kelli F. Johnson #' @return todo: document what checkGrade returns. -#' +#' checkGrade <- function(Pdata) { - out <- tapply(Pdata$GRADE, Pdata$SAMPLE_NO, - function(x) length(unique(x)) == 1) + out <- tapply( + Pdata$GRADE, Pdata$SAMPLE_NO, + function(x) length(unique(x)) == 1 + ) ifelse(all(out == 1), "One grade per sample number.", - "More than one grade per sample number.") + "More than one grade per sample number." + ) } diff --git a/R/checkLenAge.R b/R/checkLenAge.R index 438d8b4..80befd9 100644 --- a/R/checkLenAge.R +++ b/R/checkLenAge.R @@ -1,5 +1,5 @@ #' Calculate von Bertalanffy Growth Parameters -#' +#' #' Calaculate the von Bertalanffy growth parameters and compare them to #' parameters estimated when outliers are removed from the data set. #' Outliers are determined using standard deviations @@ -42,7 +42,7 @@ #' nothing is saved. #' #' @return Returns a combined dataset in PacFIN format. -#' +#' #' @export #' @author Chantel R. Wetzel, Vlada Gertseva, James Thorson @@ -64,7 +64,6 @@ checkLenAge <- function(Pdata, precision = 1, verbose = TRUE, dir = NULL) { - #### Initialize the three new columns Pdata$Lhat_pred <- NA Pdata$Lhat_low <- NA @@ -86,12 +85,15 @@ checkLenAge <- function(Pdata, } if (length(Par[[1]]) > 1) { if (stats::var(unlist(lapply(Par, length))) != 0) { - stop("Must be one named entry in each vector element of the list Par\n", + stop( + "Must be one named entry in each vector element of the list Par\n", "for each unique sex type in the data, e.g.,\n", - paste(sex_vec, collapse = ", ")) + paste(sex_vec, collapse = ", ") + ) } if (!all(sex_vec %in% names(Par[[1]]))) { - stop("The data contains the following values for sexes,\n", + stop( + "The data contains the following values for sexes,\n", paste(sex_vec, collapse = ", "), "\n", " which must match names of the parameter vectors in the list Par, e.g.,\n", paste(unique(unlist(lapply(Par, names))), collapse = ", ") @@ -106,33 +108,37 @@ checkLenAge <- function(Pdata, #### For each sex for (s in seq_along(sex_vec)) { use_data <- !is.na(Pdata[, len_col]) & - !is.na(Pdata[, age_col]) & - Pdata[, sex_col] %in% sex_vec[s] + !is.na(Pdata[, age_col]) & + Pdata[, sex_col] %in% sex_vec[s] if (length(Par[[1]]) > 1) { - pars_in <- c( - Par[[1]][sex_vec[s]], - Par[[2]][sex_vec[s]] * mult, - Par[[3]][sex_vec[s]] * mult, - Par[[4]][sex_vec[s]], - Par[[5]][sex_vec[s]]) + pars_in <- c( + Par[[1]][sex_vec[s]], + Par[[2]][sex_vec[s]] * mult, + Par[[3]][sex_vec[s]] * mult, + Par[[4]][sex_vec[s]], + Par[[5]][sex_vec[s]] + ) } else { - pars_in <- c( - Par[[1]][1], - Par[[2]][1] * mult, - Par[[3]][1] * mult, - Par[[4]][1], - Par[[5]][1]) + pars_in <- c( + Par[[1]][1], + Par[[2]][1] * mult, + Par[[3]][1] * mult, + Par[[4]][1], + Par[[5]][1] + ) } if (Optim) { - ests <- stats::optim(fn = nwfscSurvey::fit_vbgrowth, - par = log(pars_in), - hessian = FALSE, - Ages = Pdata[use_data, age_col], - Lengths = Pdata[use_data, len_col])$par + ests <- stats::optim( + fn = nwfscSurvey::fit_vbgrowth, + par = log(pars_in), + hessian = FALSE, + Ages = Pdata[use_data, age_col], + Lengths = Pdata[use_data, len_col] + )$par } else { - ests <- pars_in + ests <- pars_in } Pred <- nwfscSurvey::fit_vbgrowth( @@ -140,15 +146,17 @@ checkLenAge <- function(Pdata, ReturnType = "Pred", sdFactor = sdFactor, Ages = Pdata[use_data, age_col], - Lengths = Pdata[use_data, len_col]) + Lengths = Pdata[use_data, len_col] + ) - Pdata[use_data, c("Lhat_low","Lhat_pred", "Lhat_high")] <- round(Pred, precision) + Pdata[use_data, c("Lhat_low", "Lhat_pred", "Lhat_high")] <- round(Pred, precision) } if (!keepAll) { remove <- which( Pdata[, len_col] > Pdata[, "Lhat_high"] | - Pdata[, len_col] < Pdata[, "Lhat_low"]) + Pdata[, len_col] < Pdata[, "Lhat_low"] + ) all <- Pdata Pdata[remove, len_col] <- NA } @@ -161,19 +169,28 @@ checkLenAge <- function(Pdata, # Estimate pars again b/c some data may be removed if !keepAll tempdata <- Pdata[ !is.na(Pdata[, len_col]) & - !is.na(Pdata[, age_col]), ] - estsall <- data.frame(Sex = sex_vec, - do.call("rbind", tapply(seq(NROW(tempdata)), tempdata[, sex_col], - function(x) exp(stats::optim(fn = nwfscSurvey::fit_vbgrowth, - par = log(pars_in), - hessian = FALSE, - Ages = tempdata[x, age_col], - Lengths = tempdata[x, len_col])$par) - ))) + !is.na(Pdata[, age_col]), + ] + estsall <- data.frame( + Sex = sex_vec, + do.call("rbind", tapply( + seq(NROW(tempdata)), tempdata[, sex_col], + function(x) { + exp(stats::optim( + fn = nwfscSurvey::fit_vbgrowth, + par = log(pars_in), + hessian = FALSE, + Ages = tempdata[x, age_col], + Lengths = tempdata[x, len_col] + )$par) + } + )) + ) colnames(estsall)[-1] <- names(Par) estsall <- estsall[, c("Sex", "L0", "Linf", "K", "CV0", "CV1")] colnames(estsall) <- c("Sex", "$L_0$", "$L_{Inf}$", "$K$", "$CV_{young}$", "$CV_{old}$") - x <- knitr::kable(estsall, format = "latex", + x <- knitr::kable(estsall, + format = "latex", label = "PacFIN_vonBpars", escape = FALSE, booktabs = TRUE, caption = paste0( "Estimates of von Bertalanffy growth parameters in terms of ", @@ -182,21 +199,25 @@ checkLenAge <- function(Pdata, ifelse(all(estsall[, "Sex"] == "A"), "", "are sex-specific (row) and "), "include $L_0$, length at maximum age ($L_{Inf}$), growth rate ($K$), and ", "coefficients of variation at young ($CV_{young}$) and old ages ($CV_{old}$).", - ifelse(keepAll, " Data used to fit the model included outliers.", "")) + ifelse(keepAll, " Data used to fit the model included outliers.", "") + ) ) writeLines(x, file.path(dir, "PacFIN_vonBpars.tex")) - utils::write.table(estsall, file = file.path(dir, "PacFIN_vonBpars.csv"), - sep = ",", row.names = FALSE) - tempdata <- tempdata[, c(len_col, age_col, sex_col)] - colnames(tempdata) <- c("Length_cm", "Age", "Sex") - pars <- unlist(estsall[1, c(3, 4, 2, 5, 6), drop = TRUE]) - names(pars) <- NULL + utils::write.table(estsall, + file = file.path(dir, "PacFIN_vonBpars.csv"), + sep = ",", row.names = FALSE + ) + tempdata <- tempdata[, c(len_col, age_col, sex_col)] + colnames(tempdata) <- c("Length_cm", "Age", "Sex") + pars <- unlist(estsall[1, c(3, 4, 2, 5, 6), drop = TRUE]) + names(pars) <- NULL - latage <- nwfscSurvey::PlotVarLengthAtAge.fn( - dat = tempdata, parStart = pars, - dir = dir, main = "PacFIN", ageBin = 1, - bySex = !all(estsall[, "Sex"] == "A"), - estVB = TRUE, legX = "bottomleft", dopng = TRUE) + latage <- nwfscSurvey::PlotVarLengthAtAge.fn( + dat = tempdata, parStart = pars, + dir = dir, main = "PacFIN", ageBin = 1, + bySex = !all(estsall[, "Sex"] == "A"), + estVB = TRUE, legX = "bottomleft", dopng = TRUE + ) } Pdata <- Pdata[, !grepl("ignore", colnames(Pdata))] diff --git a/R/cleanColumns.R b/R/cleanColumns.R index ba0cdf1..176ffba 100644 --- a/R/cleanColumns.R +++ b/R/cleanColumns.R @@ -35,8 +35,9 @@ cleanColumns <- function(data) { #' @return A data frame with fewer columns and some column names changed. #' cleanColumns.bds <- function(data) { - - master <- matrix(scan(text = " + master <- matrix( + scan( + text = " Comp_FT vdrfd ADJUSTED_CLUSTER_WEIGHT_LBS ADJ_CLWT AGENCY_AGE_STRUCTURE_CODE AGE_STRUCT_AGCODE @@ -79,15 +80,18 @@ cleanColumns.bds <- function(data) { WEIGHT_OF_MALES_LBS MALES_WGT WEIGHT_OF_LANDING_LBS TOTAL_WGT ", - quiet = TRUE, what = "", strip.white = TRUE), - ncol = 2, byrow = TRUE) + quiet = TRUE, what = "", strip.white = TRUE + ), + ncol = 2, byrow = TRUE + ) colnames(master) <- c("raw", "vdrfd") matches <- match(colnames(data), master[, "raw"]) colnames(data) <- ifelse(is.na(matches), colnames(data), - master[matches, "vdrfd"]) + master[matches, "vdrfd"] + ) - # CRW: Columns have been collapsed to have + # CRW: Columns have been collapsed to have # TOTAL_WGT for CA and RWT_LBS for WA. data$RWT_LBS <- data$TOTAL_WGT data <- data %>% @@ -107,13 +111,11 @@ cleanColumns.bds <- function(data) { #' @return A data frame with fewer columns. #' cleanColumns.catch <- function(data) { - #### REMOVE columns that are redundant and make things cluttered data <- data %>% dplyr::select(dplyr::matches("LANDING|AGENCY|GEAR|AREA|_MT|_LBS|PORT|^[RCF].+_CODE")) return(data) - } check_columns_downloaded <- function(x) { diff --git a/R/cleanPacFIN.R b/R/cleanPacFIN.R index b977449..230ec8f 100644 --- a/R/cleanPacFIN.R +++ b/R/cleanPacFIN.R @@ -142,7 +142,6 @@ cleanPacFIN <- function(Pdata, spp = NULL, verbose = TRUE, savedir) { - #### Deprecate old input arguments if (lifecycle::is_present(keep_INPFC)) { lifecycle::deprecate_stop( @@ -151,8 +150,8 @@ cleanPacFIN <- function(Pdata, details = paste0( "It is thought that PSMFC areas can decipher much of what was\n", "previously determined with INPFC areas." - ) ) + ) } if (lifecycle::is_present(keep_missing_lengths)) { lifecycle::deprecate_stop( @@ -161,8 +160,8 @@ cleanPacFIN <- function(Pdata, details = paste0( "All down-stream functionality works without filtering,\n", "but Pdata[is.na(Pdata[['length']]), ] can be used to filter them out." - ) ) + ) } #### CLEAN COLUMNS @@ -178,13 +177,15 @@ cleanPacFIN <- function(Pdata, } Pdata[, "fleet"] <- match(Pdata$geargroup, keep_gears) if (missing(keep_length_type)) { - keep_length_type <- sort(unique(c(Pdata[, "FISH_LENGTH_TYPE"], - "", "A", "D", "F", "R", "S", "T", "U", NA))) + keep_length_type <- sort(unique(c( + Pdata[, "FISH_LENGTH_TYPE"], + "", "A", "D", "F", "R", "S", "T", "U", NA + ))) } if (is.null(keep_age_method)) { keep_age_method <- unique( unlist(Pdata[, grep("AGE_METHOD[0-9]*$", colnames(Pdata))]) - ) + ) } #### Column names @@ -197,12 +198,16 @@ cleanPacFIN <- function(Pdata, grDevices::png(filename = file.path(savedir, "PacFIN_comp_season.png")) on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) } - Pdata <- getSeason(Pdata, verbose = verbose, - plotResults = !missing(savedir)) + Pdata <- getSeason(Pdata, + verbose = verbose, + plotResults = !missing(savedir) + ) #### Areas - Pdata <- getState(Pdata, verbose = verbose, - source = ifelse("AGID" %in% colnames(Pdata), "AGID", "SOURCE_AGID")) + Pdata <- getState(Pdata, + verbose = verbose, + source = ifelse("AGID" %in% colnames(Pdata), "AGID", "SOURCE_AGID") + ) # California doesn't record SAMPLE_TYPE so we assume they are all Market samples Pdata[Pdata$state == "CA" & is.na(Pdata$SAMPLE_TYPE), "SAMPLE_TYPE"] <- "M" @@ -210,8 +215,10 @@ cleanPacFIN <- function(Pdata, Pdata[, "SEX"] <- nwfscSurvey::codify_sex(Pdata[, "SEX"]) #### Lengths - Pdata[, "length"] <- getLength(Pdata, verbose = verbose, - keep = keep_length_type) + Pdata[, "length"] <- getLength(Pdata, + verbose = verbose, + keep = keep_length_type + ) Pdata[, "lengthcm"] <- floor(Pdata[, "length"] / 10) #### Age (originally in cleanAges) @@ -229,7 +236,7 @@ cleanPacFIN <- function(Pdata, weight = Pdata[["FISH_WEIGHT"]], unit.in = Pdata[["FISH_WEIGHT_UNITS"]], unit.out = "kg" - ) + ) #### Bad samples # Remove bad OR samples @@ -254,16 +261,24 @@ cleanPacFIN <- function(Pdata, # Report removals if (verbose) { message("\n") - message("N SAMPLE_TYPEs changed from M to S", + message( + "N SAMPLE_TYPEs changed from M to S", " for special samples from OR: ", - sum(Pdata$SAMPLE_NO %in% paste0("OR", badORnums))) - message("N not in keep_sample_type (SAMPLE_TYPE): ", - sum(!bad[, "goodstype"])) + sum(Pdata$SAMPLE_NO %in% paste0("OR", badORnums)) + ) + message( + "N not in keep_sample_type (SAMPLE_TYPE): ", + sum(!bad[, "goodstype"]) + ) message("N with SAMPLE_TYPE of NA: ", sum(is.na(Pdata[["SAMPLE_TYPE"]]))) - message("N not in keep_sample_method (SAMPLE_METHOD): ", - sum(!bad[, "goodsmeth"])) - message("N with SAMPLE_NO of NA: ", - sum(!bad[, "goodsno"])) + message( + "N not in keep_sample_method (SAMPLE_METHOD): ", + sum(!bad[, "goodsmeth"]) + ) + message( + "N with SAMPLE_NO of NA: ", + sum(!bad[, "goodsno"]) + ) message("N without length: ", sum(is.na(Pdata$length))) message("N without Age: ", sum(is.na(Pdata$Age))) message("N without length and Age: ", sum(is.na(Pdata$length) | is.na(Pdata$Age))) @@ -295,13 +310,17 @@ cleanPacFIN <- function(Pdata, if (!missing(savedir)) { wlpars <- getWLpars(Pdata, verbose = FALSE) - utils::write.table(wlpars, sep = ",", + utils::write.table(wlpars, + sep = ",", row.names = FALSE, col.names = TRUE, - file = file.path(savedir, "PacFIN_WLpars.csv")) + file = file.path(savedir, "PacFIN_WLpars.csv") + ) if (verbose) { - message("WL parameter estimates: see 'PacFIN_WLpars.csv'\n", + message( + "WL parameter estimates: see 'PacFIN_WLpars.csv'\n", "If some rows are NA, consider setting ALL of them individually\n", - "'getExpansion_1('fa' = , 'fb' = , 'ma' = , ...)") + "'getExpansion_1('fa' = , 'fb' = , 'ma' = , ...)" + ) } } diff --git a/R/comps_bins.R b/R/comps_bins.R index bd57e9c..f455091 100644 --- a/R/comps_bins.R +++ b/R/comps_bins.R @@ -1,5 +1,5 @@ #' Bin a vector of data into groups -#' +#' #' Bin a vector of data into distinct groups, this is often helpful #' for grouping ages or lengths into bin categories if every year or #' centimeter is not its own bin. @@ -8,15 +8,15 @@ #' @template breaks #' @template includeplusgroup #' @template returnclass -#' +#' #' @export #' @author Kelli F. Johnson #' @examples #' comps_bins(1:8, breaks = c(-Inf, 3:5)) #' comps_bins(1:8, breaks = c(3:5), includeplusgroup = FALSE) #' testthat::expect_equal( -#' comps_bins(1:8, breaks = c(-Inf, 3:5, Inf)), -#' comps_bins(1:8, breaks = c(-Inf, 3:5), includeplusgroup = TRUE) +#' comps_bins(1:8, breaks = c(-Inf, 3:5, Inf)), +#' comps_bins(1:8, breaks = c(-Inf, 3:5), includeplusgroup = TRUE) #' ) #' comps_bins <- function(vector, @@ -33,11 +33,14 @@ comps_bins <- function(vector, # also used as a special character to represent ranges pattern = "[\\[\\(]([0-9\\Inf-]+),\\s*[0-9Inf\\)]+", replacement = "\\1", - x = cut(vector, breaks = breaks, - include.lowest = FALSE, right = FALSE) + x = cut(vector, + breaks = breaks, + include.lowest = FALSE, right = FALSE ) + ) out <- switch(returnclass, character = out, - numeric = utils::type.convert(out, as.is = TRUE)) + numeric = utils::type.convert(out, as.is = TRUE) + ) return(out) } diff --git a/R/comps_wide.R b/R/comps_wide.R index ea16e6b..74415fc 100644 --- a/R/comps_wide.R +++ b/R/comps_wide.R @@ -30,7 +30,8 @@ #' state = rep(c("WA", "OR"), length.out = 30), #' year = rep(2010:2015, each = 5), #' Age = rep(1:15, 2), -#' ap = rlnorm(n = 30)) +#' ap = rlnorm(n = 30) +#' ) #' comps <- comps_wide(temp, breaks = 3:8, col_proportions = "ap") #' testthat::expect_equal(NCOL(comps), 8) #' \dontrun{ @@ -42,26 +43,31 @@ comps_wide <- function(data, col_bins = "Age", col_proportions = "lf", includeplusgroup = TRUE) { - col_proportions.num <- which(colnames(data) == col_proportions) col_bins.num <- which(colnames(data) == col_bins) stopifnot(length(col_proportions.num) == 1) stopifnot(length(col_bins.num) == 1) - data <- data[, c(seq_along(data)[-c(col_bins.num, col_proportions.num)], - col_bins.num, col_proportions.num)] + data <- data[, c( + seq_along(data)[-c(col_bins.num, col_proportions.num)], + col_bins.num, col_proportions.num + )] data[, NCOL(data) - 1] <- comps_bins( vector = data[, NCOL(data) - 1, drop = TRUE], breaks = breaks, includeplusgroup = includeplusgroup, returnclass = "numeric" - ) + ) outformula <- stats::formula(paste(col_proportions, "~ .")) - out <- stats::reshape(direction = "wide", stats::aggregate(outformula, data = data, sum), - idvar = colnames(data)[1:(NCOL(data)-2)], - timevar = colnames(data)[NCOL(data)-1]) + out <- stats::reshape( + direction = "wide", stats::aggregate(outformula, data = data, sum), + idvar = colnames(data)[1:(NCOL(data) - 2)], + timevar = colnames(data)[NCOL(data) - 1] + ) out[is.na(out)] <- 0 - out <- out[do.call(order, - as.list(out[, colnames(out)[-(NCOL(out):(NCOL(out)-1))]])), ] + out <- out[do.call( + order, + as.list(out[, colnames(out)[-(NCOL(out):(NCOL(out) - 1))]]) + ), ] return(out) } diff --git a/R/convertlength_skate.R b/R/convertlength_skate.R index ffa74c6..87875a5 100644 --- a/R/convertlength_skate.R +++ b/R/convertlength_skate.R @@ -1,25 +1,25 @@ #' Convert Disc and Interspiracular Width to Length #' -#' Convert from disc and interspiracular width to length for skates, -#' Conversion parameters were derived from +#' Convert from disc and interspiracular width to length for skates, +#' Conversion parameters were derived from #' West Coast Groundfish Bottom Trawl Survey data. -#' +#' #' @template Pdata #' @param returntype A character value from the list supplied that specifies -#' the data you want returned. +#' the data you want returned. #' \itemize{ -#' \item {\code{"all"}} {all lengths with the new estimates replacing -#' the input lengths} -#' \item {\code{"estimated"}} {only the estimat lengths +#' \item {\code{"all"}} {all lengths with the new estimates replacing +#' the input lengths} +#' \item {\code{"estimated"}} {only the estimat lengths #' with all other lengths as NA such that the #' returned vector is the same length and the number of rows of the input data #' frame.} #' } #' @export #' @author Kelli F. Johnson and Vladlena Gertseva -#' @return A vector of lengths. +#' @return A vector of lengths. #' See \code{returntype} for detailed information on what can be returned. -#' +#' convertlength_skate <- function(Pdata, returntype = c("all", "estimated")) { matchcol <- function(data) { @@ -37,22 +37,25 @@ convertlength_skate <- function(Pdata, ) } returntype <- match.arg(returntype, several.ok = FALSE) - + # Conversion parameters discpar <- data.frame( "SEX" = rep(c("F", "M", "U"), 2), "FISH_LENGTH_TYPE" = c(rep("A", 3), rep("R", 3)), "multiply" = c(c(1.4021, 1.4058, 1.4044), c(12.538, 13.172, 12.538)), - "add" = c(c(9.117, 5.2334, 7.005), c(70.48, 35.21, 70.48))) + "add" = c(c(9.117, 5.2334, 7.005), c(70.48, 35.21, 70.48)) + ) discpar[, "match"] <- matchcol(discpar) matches <- match(matchcol(Pdata), discpar[, "match"]) - - est <- Pdata[, "FISH_LENGTH"] * discpar[matches, "multiply"] + + + est <- Pdata[, "FISH_LENGTH"] * discpar[matches, "multiply"] + discpar[matches, "add"] - + returned <- switch(returntype, - all = ifelse(Pdata[, "FISH_LENGTH_TYPE"] %in% c("A", "R"), - est, Pdata[, "FISH_LENGTH"]), - estimated = est) + all = ifelse(Pdata[, "FISH_LENGTH_TYPE"] %in% c("A", "R"), + est, Pdata[, "FISH_LENGTH"] + ), + estimated = est + ) return(returned) } diff --git a/R/doSexRatio.R b/R/doSexRatio.R index 4b5706e..f160f3c 100644 --- a/R/doSexRatio.R +++ b/R/doSexRatio.R @@ -1,5 +1,5 @@ #' Assign gender for unsexed fish -#' +#' #' @description #' Assign sex to unsexed fish based on a pre-determined sex ratio in #' age- or length-composition data. @@ -40,11 +40,11 @@ #' the values for males and females in the comps have increased). #' The original columns for unsexed fish remain unchanged. #' [writeComps] will set the observations of unsexed fish to zero. -#' +#' #' @author -#' +#' #' Andi Stephens, Kelli F. Johnson, and Chantel R. Wetzel -#' +#' #' @seealso #' [getComps], [writeComps] #' @@ -54,75 +54,78 @@ doSexRatio <- function(CompData, maxsizeU, GTsizeU, savedir) { - # If AGE comps, Bins are ages, not lengths. Rename "age" to "lengthcm", then put # it back at the end! - AGE_FLAG = FALSE - if ( length(CompData$lengthcm) == 0 ) { - index = which(names(CompData) == "Age") - names(CompData)[index] = "lengthcm" - AGE_FLAG = TRUE + AGE_FLAG <- FALSE + if (length(CompData$lengthcm) == 0) { + index <- which(names(CompData) == "Age") + names(CompData)[index] <- "lengthcm" + AGE_FLAG <- TRUE } # End if # Fix arithmetic - CompList = c("male", "msamps", "mtows", - "female", "fsamps", "ftows", - "unsexed", "usamps", "ONLY_U_TOWS", - "alltows") - tmp = CompData[,CompList] - tmp[is.na(tmp)] = 0 - CompData[,CompList] = tmp - + CompList <- c( + "male", "msamps", "mtows", + "female", "fsamps", "ftows", + "unsexed", "usamps", "ONLY_U_TOWS", + "alltows" + ) + tmp <- CompData[, CompList] + tmp[is.na(tmp)] <- 0 + CompData[, CompList] <- tmp + if (!missing(ratioU) & missing(maxsizeU)) { - stop("Error: The maxsizeU needs to be specified if you are using ratioU") + stop("Error: The maxsizeU needs to be specified if you are using ratioU") } calcRatio <- prop.table(x = as.matrix(CompData[, c("female", "male")]), margin = 1)[, 1] # Check to see if some years are only unsexed - CompData$percent_unsexed <- CompData$usamps / - (CompData$usamps + CompData$fsamps + CompData$msamps) - check <- stats::aggregate(percent_unsexed~fishyr, CompData, function(x) sum(x == 1) / sum(x) ) - yrs <- check[,'percent_unsexed'] == 1 & is.finite(check[, 'percent_unsexed']) - n <- sum(yrs, na.rm = TRUE) - if(n > 0 ) { - message("Thera are ", n, " years (", - unique(check[yrs,'fishyr']), ") with only unsexed fish. Applying sex ratio to these years may not be ideal.") - } + CompData$percent_unsexed <- CompData$usamps / + (CompData$usamps + CompData$fsamps + CompData$msamps) + check <- stats::aggregate(percent_unsexed ~ fishyr, CompData, function(x) sum(x == 1) / sum(x)) + yrs <- check[, "percent_unsexed"] == 1 & is.finite(check[, "percent_unsexed"]) + n <- sum(yrs, na.rm = TRUE) + if (n > 0) { + message( + "Thera are ", n, " years (", + unique(check[yrs, "fishyr"]), ") with only unsexed fish. Applying sex ratio to these years may not be ideal." + ) + } # Deal with NaNs noRatio <- which(!is.finite(calcRatio)) - for(i in noRatio){ + for (i in noRatio) { # 1st: Try to fill in based on neighboring lengths within a year # Initially, I was also using fleet but appeared to lead to increased # variability in the sex ratio being calculated. - nearLens <- c((CompData[i, 'lengthcm'] - 2):(CompData[i, 'lengthcm'] + 2)) - ind <- which(CompData[, 'fishyr'] == CompData[i, 'fishyr'] & - CompData[ , 'lengthcm'] %in% nearLens ) + nearLens <- c((CompData[i, "lengthcm"] - 2):(CompData[i, "lengthcm"] + 2)) + ind <- which(CompData[, "fishyr"] == CompData[i, "fishyr"] & + CompData[, "lengthcm"] %in% nearLens) # Only use if the observations are 3 or greater # One will be the missing sex ratio, so a 3 or more would indicate more than # one near neighbor observation - if (length(ind) >= 3 & sum(!is.finite(calcRatio[ind])) != length(ind)){ - calcRatio[i] <- mean(calcRatio[ind], na.rm = TRUE) - } else{ - # 2nd: Use sex ratio for the same length across all data - ind <- which(CompData[, 'lengthcm'] == CompData[i,'lengthcm']) - calcRatio[i] <- mean(calcRatio[ind], na.rm = T) + if (length(ind) >= 3 & sum(!is.finite(calcRatio[ind])) != length(ind)) { + calcRatio[i] <- mean(calcRatio[ind], na.rm = TRUE) + } else { + # 2nd: Use sex ratio for the same length across all data + ind <- which(CompData[, "lengthcm"] == CompData[i, "lengthcm"]) + calcRatio[i] <- mean(calcRatio[ind], na.rm = T) } } # Now let's check small fish if user has pre-specified ratio to be applied - if(!missing(maxsizeU)){ - ind <- which(CompData[, 'usamps'] > 0 & CompData[, 'lengthcm'] < maxsizeU) - if (length(ind) > 0){ + if (!missing(maxsizeU)) { + ind <- which(CompData[, "usamps"] > 0 & CompData[, "lengthcm"] < maxsizeU) + if (length(ind) > 0) { calcRatio[ind] <- ratioU } } - if(!missing(GTsizeU)){ - ind <- which(CompData[, 'usamps'] > 0 & CompData[, 'lengthcm'] > GTsizeU) - if (length(ind) > 0){ + if (!missing(GTsizeU)) { + ind <- which(CompData[, "usamps"] > 0 & CompData[, "lengthcm"] > GTsizeU) + if (length(ind) > 0) { calcRatio[ind] <- 1.0 } } @@ -130,34 +133,33 @@ doSexRatio <- function(CompData, CompData$sexRatio <- calcRatio # Now let's apply the calcRatio to all the unsexed fish: - for ( i in 1:nrow(CompData) ) { + for (i in 1:nrow(CompData)) { CompData$female[i] <- CompData$female[i] + CompData$unsexed[i] * calcRatio[i] CompData$fsamps[i] <- CompData$fsamps[i] + CompData$usamps[i] * calcRatio[i] - CompData$ftows[i] <- CompData$ftows[i] + CompData$ONLY_U_TOWS[i] * calcRatio[i] - CompData$male[i] <- CompData$male[i] + CompData$unsexed[i] * ( 1 - calcRatio[i] ) - CompData$msamps[i] <- CompData$msamps[i] + CompData$usamps[i] * ( 1 - calcRatio[i] ) - CompData$mtows[i] <- CompData$mtows[i] + CompData$ONLY_U_TOWS[i] * ( 1 - calcRatio[i] ) - } + CompData$ftows[i] <- CompData$ftows[i] + CompData$ONLY_U_TOWS[i] * calcRatio[i] + CompData$male[i] <- CompData$male[i] + CompData$unsexed[i] * (1 - calcRatio[i]) + CompData$msamps[i] <- CompData$msamps[i] + CompData$usamps[i] * (1 - calcRatio[i]) + CompData$mtows[i] <- CompData$mtows[i] + CompData$ONLY_U_TOWS[i] * (1 - calcRatio[i]) + } if (!missing(savedir)) { - find = which(CompData$usamps > 0 ) + find <- which(CompData$usamps > 0) grDevices::png(file.path(savedir, "Applied_Sex_Ratio_to_Unsexed_Fish.png")) - on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) - plot(CompData[find,'lengthcm'], CompData[find, 'sexRatio'], - xlab = "Length (cm)", ylab = "Sex Ratio", - main = paste0("Sex Ratio Applied to Unsexed Fish (N = ", sum(CompData$usamps), ")" ) - ) + on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) + plot(CompData[find, "lengthcm"], CompData[find, "sexRatio"], + xlab = "Length (cm)", ylab = "Sex Ratio", + main = paste0("Sex Ratio Applied to Unsexed Fish (N = ", sum(CompData$usamps), ")") + ) } # If AGE comps, Bins are ages, not lengths. Rename "age" to "lengthcm", then put # it back at the end! if (AGE_FLAG) { - index = which(names(CompData) == "lengthcm") - names(CompData)[index] = "Age" + index <- which(names(CompData) == "lengthcm") + names(CompData)[index] <- "Age" } # End if cat("\nDone.\n\n") return(CompData) - } # End doSexRatio diff --git a/R/find.matching.rows.R b/R/find.matching.rows.R index 966ad5e..b130a06 100644 --- a/R/find.matching.rows.R +++ b/R/find.matching.rows.R @@ -1,5 +1,5 @@ #' Function find.matching.rows -#' +#' #' @description #' Takes two tables with a shared primary key, and #' returns the rows of the second table for which the @@ -13,7 +13,7 @@ #' @param tcol Still mysterious. #' @param round. if values are numeric, round. Default: TRUE. #' @author John R. Wallace (John.Wallace@@noaa.gov), (revised) Andi Stephens, 2010. -#' +#' #' @details #' NOTE: The way this is written assumes that the second table is a #' superset of the first (i.e., that each value is matched). @@ -38,7 +38,6 @@ find.matching.rows <- function(file, tindex = 1, tcol = 2, round. = TRUE) { - # Coerce a vector argument into a matrix if (is.null(dim(file))) { @@ -48,7 +47,6 @@ find.matching.rows <- function(file, # If the primary keys are numeric, round them. if (round.) { - if (is.numeric(file[, findex])) { file[, findex] <- round(file[, findex]) } @@ -56,7 +54,6 @@ find.matching.rows <- function(file, if (is.numeric(table[, tindex])) { table[, tindex] <- round(table[, tindex]) } - } # End if round. # Convert the indices to character strings for comparison, and get the @@ -64,10 +61,10 @@ find.matching.rows <- function(file, matched.rows <- match( apply(file[, findex, drop = FALSE], 1, paste, collapse = " "), - apply(table[, tindex, drop = FALSE], 1, paste, collapse = " ")) + apply(table[, tindex, drop = FALSE], 1, paste, collapse = " ") + ) # Return the 'tcol' values in the rows of the 'table' that matched. return(table[matched.rows, tcol, drop = FALSE]) - } # End function find.matching.rows diff --git a/R/formatCatch.R b/R/formatCatch.R index 4cc5f84..e7765e2 100644 --- a/R/formatCatch.R +++ b/R/formatCatch.R @@ -1,16 +1,16 @@ #' Format catches from long to wide -#' +#' #' Transform a long data frame of catches to a wide data frame #' using [tidyr::pivot_wider]. #' The column names of the wide data frame will be in the format #' needed for the stratification of stage-2 expansions of #' composition data, i.e., [getExpansion_2]. -#' +#' #' @param catch A data frame with at least a column specifying #' the year the catches took place #' (e.g., LANDING_YEAR is the column name upon download from PacFIN), #' a column for variable(s) specified in strat, and -#' a column that holds the measured catches named +#' a column that holds the measured catches named #' (e.g., ROUND_WEIGHT_LBS is the column name upon download from PacFIN). #' @inheritParams tableSample #' @param yearname A character string used to search for year in `catch`. @@ -40,7 +40,6 @@ formatCatch <- function(catch, strat, yearname = "^Year|^Yr|Landing_Y|Sample_Y", valuename = "ROUND_WEIGHT_LBS") { - if ("state" %in% strat & !"state" %in% colnames(catch)) { catch <- getState(catch, verbose = FALSE) } @@ -49,13 +48,14 @@ formatCatch <- function(catch, } # Reshape the data into wide format and replace NA with zeros - out <- catch %>% tidyr::pivot_wider( - values_fn = sum, values_fill = 0, - id_cols = dplyr::matches(match = yearname, ignore.case = TRUE), - names_from = strat, names_sep = ".", - values_from = dplyr::matches(match = valuename, ignore.case = TRUE) - ) %>% data.frame() + out <- catch %>% + tidyr::pivot_wider( + values_fn = sum, values_fill = 0, + id_cols = dplyr::matches(match = yearname, ignore.case = TRUE), + names_from = strat, names_sep = ".", + values_from = dplyr::matches(match = valuename, ignore.case = TRUE) + ) %>% + data.frame() return(out) - } diff --git a/R/getArea.R b/R/getArea.R index 3feb0e0..9adbac6 100644 --- a/R/getArea.R +++ b/R/getArea.R @@ -20,7 +20,7 @@ #' fish tickets. See Table 3 on page 15 of [Tsou et al. #' (2015)](https://wdfw.wa.gov/sites/default/files/publications/01754/wdfw01754.pdf) #' for a table that converts WDFW management region to PSMFC area. -#' +#' #' A partial map of the WDFW management regions for the Puget Sound areas is #' provided in the [Puget Sound Groundfish Management #' Plan](https://wdfw.wa.gov/sites/default/files/publications/00927/wdfw00927.pdf) diff --git a/R/getExpansion_1.R b/R/getExpansion_1.R index 2a44d5d..5ef036a 100644 --- a/R/getExpansion_1.R +++ b/R/getExpansion_1.R @@ -45,7 +45,6 @@ getExpansion_1 <- function(Pdata, ub = NA, verbose = TRUE, plot = FALSE) { - # Calculate length-weight relationship if (all(mapply(is.na, c(fa, ma, ua)))) { pars <- getWLpars(data = Pdata, verbose = verbose) @@ -59,27 +58,34 @@ getExpansion_1 <- function(Pdata, if (is.character(plot)) { plot.denom <- ifelse(grepl("png", tools::file_ext(plot)), - dirname(plot), plot) + dirname(plot), plot + ) } else { if (plot == TRUE) { plot.denom <- TRUE - } else plot.denom <- FALSE + } else { + plot.denom <- FALSE + } } Pdata <- EF1_Denominator(Pdata, fa = fa, fb = fb, ma = ma, mb = mb, ua = ua, ub = ub, - verbose = verbose, plot = plot.denom) + verbose = verbose, plot = plot.denom + ) # Get Trip_Sampled_Lbs if (is.character(plot)) { fn <- gsub(".png", "", plot) plot.num <- file.path(ifelse(!grepl("png", tools::file_ext(plot)), - plot, dirname(plot)), "PacFIN_exp1_numer.png") + plot, dirname(plot) + ), "PacFIN_exp1_numer.png") } else { if (plot == TRUE) { plot.num <- TRUE grDevices::dev.new() - } else plot.num <- FALSE + } else { + plot.num <- FALSE + } } Pdata <- EF1_Numerator(Pdata, verbose = verbose, plot = plot.num) @@ -98,7 +104,7 @@ getExpansion_1 <- function(Pdata, cat("\n\nWA expansions set to 1. Fish tickets do not represent whole trips in WA.\n\n") } # End if - NA_EF1 <- Pdata[is.na(Pdata$Expansion_Factor_1_L),] + NA_EF1 <- Pdata[is.na(Pdata$Expansion_Factor_1_L), ] nNA <- NROW(NA_EF1) if (verbose) { @@ -118,24 +124,27 @@ getExpansion_1 <- function(Pdata, } # Generate plots and save them to the disk if specified. - if (plot != FALSE){ - + if (plot != FALSE) { if (is.character(plot)) { grDevices::png(file.path(ifelse(!grepl("png", tools::file_ext(plot)), - plot, dirname(plot)), "PacFIN_exp1.png")) + plot, dirname(plot) + ), "PacFIN_exp1.png")) } else { grDevices::dev.new() } if (nNA > 0) { # Plot NA values by year and state. Early years data or CALCOM data? - graphics::par(mfrow = c(2, 1), mar = c(0, 3, 0, 0), oma = c(4, 1, 3, 0), - mgp = c(2.0, 0.5, 0)) + graphics::par( + mfrow = c(2, 1), mar = c(0, 3, 0, 0), oma = c(4, 1, 3, 0), + mgp = c(2.0, 0.5, 0) + ) allyears <- seq(min(Pdata$fishyr), max(Pdata$fishyr), by = 1) vals <- matrix(0, nrow = length(unique(NA_EF1$state)), - ncol = length(allyears)) + ncol = length(allyears) + ) rownames(vals) <- unique(NA_EF1$state) colnames(vals) <- allyears bad <- as.matrix(table(NA_EF1$state, NA_EF1$fishyr)) @@ -145,24 +154,26 @@ getExpansion_1 <- function(Pdata, col = grDevices::rainbow(length(unique(NA_EF1$state))), legend.text = TRUE, xlab = "", xaxt = "n", ylab = "Replace NA in Exp_1 with 1", - args.legend = list(bty = "n")) + args.legend = list(bty = "n") + ) } else { graphics::par( mgp = c(2, 0.5, 0), mar = c(1.5, 3, 1, 0), - mfrow = c(1, 1)) + mfrow = c(1, 1) + ) } # End if graphics::boxplot(Pdata$Expansion_Factor_1_L ~ Pdata$fishyr, - ylab ="Expansion_Factor_1_L", - xlab = "", frame.plot = FALSE) - + ylab = "Expansion_Factor_1_L", + xlab = "", frame.plot = FALSE + ) + graphics::mtext(side = 1, outer = TRUE, "Year", line = 2) - + if (is.character(plot)) { grDevices::dev.off() } } return(Pdata) - } # End function getExpansion_1 diff --git a/R/getExpansion_2.R b/R/getExpansion_2.R index 482a5cb..7ebf3ea 100644 --- a/R/getExpansion_2.R +++ b/R/getExpansion_2.R @@ -65,21 +65,25 @@ getExpansion_2 <- function(Pdata, stratification.cols, verbose = TRUE, savedir) { - #### Set up # Check Unit input - Units <- match.arg(Units, several.ok = FALSE, - choices = c(measurements::conv_unit_options[["mass"]], "MT", "LB")) + Units <- match.arg(Units, + several.ok = FALSE, + choices = c(measurements::conv_unit_options[["mass"]], "MT", "LB") + ) Units <- switch(Units, MT = "metric_ton", LB = "lbs", - Units) + Units + ) # Check and stop if Convert input is used since it is not deprecated - if(!is.null(Convert)) { - stop("Convert is deprecated.", + if (!is.null(Convert)) { + stop( + "Convert is deprecated.", "Please specify the units of Catch via the Unit input (MT or LB).\n", - paste(measurements::conv_unit_options[["mass"]], collapse = ", ")) + paste(measurements::conv_unit_options[["mass"]], collapse = ", ") + ) } # Start clean @@ -95,10 +99,14 @@ getExpansion_2 <- function(Pdata, if (length(stratification.cols) == 1) { Pdata[, "stratification"] <- Pdata[, stratification.cols] } else { - separate <- unique(gsub("^[a-zA-Z]+(\\s*[[:punct:]]\\s*)[a-zA-Z]+$", - "\\1", colnames(Catch)[-1])) - Pdata[, "stratification"] <- apply(Pdata[, stratification.cols], - 1, paste, collapse = separate) + separate <- unique(gsub( + "^[a-zA-Z]+(\\s*[[:punct:]]\\s*)[a-zA-Z]+$", + "\\1", colnames(Catch)[-1] + )) + Pdata[, "stratification"] <- apply(Pdata[, stratification.cols], + 1, paste, + collapse = separate + ) } } else { stop("Pdata must have stratification column or provide stratification.cols") @@ -119,22 +127,27 @@ getExpansion_2 <- function(Pdata, message("Data: ", paste(collapse = ", ", Pstrat)) if (sum(Pstrat %in% Catchgears) == 0) { - stop("No Pdata stratifications,\n", + stop( + "No Pdata stratifications,\n", paste(Pstrat, collapse = ", "), "\n", "were found in catch columns,\n", - paste(Catchgears, collapse = ", ")) + paste(Catchgears, collapse = ", ") + ) } else { Pdata <- Pdata[Pdata[, "stratification"] %in% colnames(Catch), ] Catch <- Catch[, c(colnames(Catch)[yearcol], unique(Pdata[, "stratification"]))] if (verbose) { message("Data were truncated to just these stratifications:") - message("Catch: ", - paste(sort(names(Catch)[-1]), collapse = ", ")) - message("Pdata: ", - paste(sort(unique(Pdata$stratification)), collapse = ", ")) + message( + "Catch: ", + paste(sort(names(Catch)[-1]), collapse = ", ") + ) + message( + "Pdata: ", + paste(sort(unique(Pdata$stratification)), collapse = ", ") + ) } } - } # End if #### Expansion @@ -152,11 +165,14 @@ getExpansion_2 <- function(Pdata, dplyr::ungroup() # Convert Catch to lbs. - Catch[, -1] <- measurements::conv_unit(to = "lbs", - x = Catch[, -1], from = Units) + Catch[, -1] <- measurements::conv_unit( + to = "lbs", + x = Catch[, -1], from = Units + ) # Matching rows in Pdata with Catch[, "Year"] and correct column in Catch - tows$catch <- apply(tows[, c("fishyr", "stratification")], 1, + tows$catch <- apply( + tows[, c("fishyr", "stratification")], 1, function(x) { Catch[match(x[1], Catch[, yearcol]), match(x[2], colnames(Catch))] } @@ -180,24 +196,32 @@ getExpansion_2 <- function(Pdata, } # Expansion is calculated by dividing the catch by the Sum_Sampled_Lbs. - tows$EF2 <- tows$catch/tows$Sum_Sampled_Lbs + tows$EF2 <- tows$catch / tows$Sum_Sampled_Lbs tows$EF2[tows$EF2 < 1 | !is.finite(tows$EF2)] <- 1 # Match EF2 to the larger dataset - Pdata$Sum_Sampled_Lbs <- find.matching.rows(Pdata, - tows, strat, strat, "Sum_Sampled_Lbs")[[1]] - Pdata$catch <- find.matching.rows(Pdata, - tows, strat, strat, "catch")[[1]] - Pdata$Expansion_Factor_2 <- find.matching.rows(Pdata, - tows, strat, strat, "EF2")[[1]] + Pdata$Sum_Sampled_Lbs <- find.matching.rows( + Pdata, + tows, strat, strat, "Sum_Sampled_Lbs" + )[[1]] + Pdata$catch <- find.matching.rows( + Pdata, + tows, strat, strat, "catch" + )[[1]] + Pdata$Expansion_Factor_2 <- find.matching.rows( + Pdata, + tows, strat, strat, "EF2" + )[[1]] NA_EF2 <- Pdata[is.na(Pdata$Expansion_Factor_2), ] nNA <- nrow(NA_EF2) Pdata$Expansion_Factor_2[is.na(Pdata$Expansion_Factor_2)] <- 1 Pdata$Expansion_Factor_2 <- capValues(Pdata$Expansion_Factor_2, maxExp) Pdata[, "Final_Sample_Size_L"] <- capValues( - Pdata$Expansion_Factor_1_L * Pdata$Expansion_Factor_2) + Pdata$Expansion_Factor_1_L * Pdata$Expansion_Factor_2 + ) Pdata[, "Final_Sample_Size_A"] <- capValues( - Pdata$Expansion_Factor_1_A * Pdata$Expansion_Factor_2) + Pdata$Expansion_Factor_1_A * Pdata$Expansion_Factor_2 + ) #### Summary information if (verbose) { @@ -215,7 +239,8 @@ getExpansion_2 <- function(Pdata, stats::xtabs(NA_EF2$FREQ ~ NA_EF2$state + NA_EF2$fishyr), col = grDevices::rainbow(3), legend.text = TRUE, xlab = "Year", ylab = "Samples", - main = "Second-stage expansion values of NA replaced by 1") + main = "Second-stage expansion values of NA replaced by 1" + ) } else { message("Specify savedir if you want a figure to show the NA Expansion_Factor_2 values replaced by 1.") } @@ -225,9 +250,9 @@ getExpansion_2 <- function(Pdata, grDevices::png(file.path(savedir, "PacFIN_exp2_summarybyyear.png")) on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) graphics::boxplot(Pdata$Expansion_Factor_2 ~ Pdata$fishyr, - main = "", xlab = "Year", ylab = "Second-stage expansion factor") + main = "", xlab = "Year", ylab = "Second-stage expansion factor" + ) } invisible(Pdata) - } # End function getExpansion_2 diff --git a/R/getGearGroup.R b/R/getGearGroup.R index 426a693..e3cf62d 100644 --- a/R/getGearGroup.R +++ b/R/getGearGroup.R @@ -24,20 +24,21 @@ #' table(ex) #' testthat::expect_equal(ex[ex[, "geargroup"] == "POT", "GRID"], "FPT") #' -getGearGroup <- function (Pdata, - spp = NULL, - verbose = TRUE) { - +getGearGroup <- function(Pdata, + spp = NULL, + verbose = TRUE) { #### Checks if (verbose) { - message("\nGear groupings reflect those in the table at\n", - "https://pacfin.psmfc.org/pacfin_pub/data_rpts_pub/code_lists/gr.txt") + message( + "\nGear groupings reflect those in the table at\n", + "https://pacfin.psmfc.org/pacfin_pub/data_rpts_pub/code_lists/gr.txt" + ) } if (!"GRID" %in% colnames(Pdata)) { if ("PACFIN_GEAR_CODE" %in% colnames(Pdata)) { Pdata[, "GRID"] <- Pdata[, "PACFIN_GEAR_CODE"] } else { - stop("Pdata must have 'GRID' or 'PACFIN_GEAR_CODE' as a column.") + stop("Pdata must have 'GRID' or 'PACFIN_GEAR_CODE' as a column.") } } if (is.factor(Pdata[, "GRID"])) { @@ -52,7 +53,8 @@ getGearGroup <- function (Pdata, if (verbose) { message("The following samples were assigned to the gear group 'MSC':") utils::write.table(table(msc[, "GRID"]), - col.names = FALSE, row.names = FALSE) + col.names = FALSE, row.names = FALSE + ) } # Danish/Scottish Seine trawl GearTable[, "GROUP"][GearTable$GRID == "DNT"] <- "MSC" @@ -64,8 +66,10 @@ getGearGroup <- function (Pdata, } # end if spp == sablefish if (any(grepl("dogfish|dsrk", spp, ignore.case = TRUE))) { if (verbose) { - message("Dogfish uses a mid-water trawl (MID), TWL (including shrimp), and HKL fleets\n", - "everything else is assigned to MSC.") + message( + "Dogfish uses a mid-water trawl (MID), TWL (including shrimp), and HKL fleets\n", + "everything else is assigned to MSC." + ) } GearTable[grepl("MIDWATER", GearTable[["DESCRIPTION"]]), "GROUP"] <- "MID" GearTable[grepl("DRG|NET|NTW|POT|TLS", GearTable[["GROUP"]]), "GROUP"] <- "MSC" @@ -76,7 +80,8 @@ getGearGroup <- function (Pdata, #### Create geargroup Pdata[, "geargroup"] <- GearTable[match(Pdata[, "GRID"], GearTable[, "GRID"]), "GROUP"] Pdata[, "geargroup"] <- ifelse(is.na(Pdata[, "geargroup"]), - Pdata[, "GRID"], Pdata[, "geargroup"]) + Pdata[, "GRID"], Pdata[, "geargroup"] + ) if (verbose) { message("GRID was assigned to geargroup with the following names:") @@ -84,5 +89,4 @@ getGearGroup <- function (Pdata, } return(Pdata) - } diff --git a/R/getLength.R b/R/getLength.R index 1ff8720..811fcc0 100644 --- a/R/getLength.R +++ b/R/getLength.R @@ -18,7 +18,6 @@ getLength <- function(Pdata, verbose = TRUE, keep) { - # Initial checks # Early return if (all(is.na(Pdata[["FISH_LENGTH"]]))) { @@ -76,12 +75,14 @@ getLength <- function(Pdata, # will eventually be removed (todo). check.calt <- which( Pdata[[var_spid]] == "DSRK" & - Pdata[[var_state]] == "C" & - Pdata[[var_fish_length_type]] == "F" + Pdata[[var_state]] == "C" & + Pdata[[var_fish_length_type]] == "F" ) if (length(check.calt) > 0) { - message("Changing ", length(check.calt), " CA FISH_LENGTH_TYPE == 'F' to 'T'.", - " Vlada is working on getting these entries fixed in PacFIN.") + message( + "Changing ", length(check.calt), " CA FISH_LENGTH_TYPE == 'F' to 'T'.", + " Vlada is working on getting these entries fixed in PacFIN." + ) Pdata[check.calt, var_fish_length_type] <- "T" } rm(check.calt) @@ -102,8 +103,10 @@ getLength <- function(Pdata, # Spiny dogfish (Squalus suckleyi; DSRK) check.dogfish <- Pdata[[var_spid]] == "DSRK" & !is.na(Pdata[["FORK_LENGTH"]]) if (sum(check.dogfish) > 0 & verbose) { - message(sum(check.dogfish), " fork lengths were converted to total lengths using\n", - "Tribuzio and Kruse (2012).") + message( + sum(check.dogfish), " fork lengths were converted to total lengths using\n", + "Tribuzio and Kruse (2012)." + ) } Pdata[check.dogfish, "FORK_LENGTH"] <- ifelse(Pdata[check.dogfish, "FISH_LENGTH_UNITS"] == "MM", 12.2, 1.22) + @@ -146,14 +149,14 @@ getLength <- function(Pdata, # Work with dorsal length if ( verbose & - "D" %in% keep & - length(grep("D", Pdata[[var_fish_length_type]]) > 0) - ) { + "D" %in% keep & + length(grep("D", Pdata[[var_fish_length_type]]) > 0) + ) { message("Using dorsal lengths, are you sure you want dorsal lengths?") } Pdata$length <- ifelse( "D" %in% keep & Pdata[[var_fish_length_type]] == "D" & - Pdata$FORK_LENGTH != Pdata$FISH_LENGTH, + Pdata$FORK_LENGTH != Pdata$FISH_LENGTH, Pdata$FORK_LENGTH, Pdata$length ) diff --git a/R/getSeason.R b/R/getSeason.R index 97833bd..9e9aea5 100644 --- a/R/getSeason.R +++ b/R/getSeason.R @@ -33,7 +33,8 @@ #' @examples #' test <- getSeason( #' data.frame(SAMPLE_MONTH = 1:12, fishyr = rep(1:2, each = 6)), -#' verbose = TRUE) +#' verbose = TRUE +#' ) #' testthat::expect_true(all(test[, "season"] == 1)) #' test <- getSeason(Pdata = test, season_type = 1, yearUp = 12) #' testthat::expect_equivalent(test[test[, "fishyr"] == 3, "season"], 1) @@ -44,61 +45,63 @@ getSeason <- function(Pdata, yearDown = NULL, plotResults = FALSE, verbose = TRUE) { - if (season_type < 0) { Pdata$season <- 1 } if (season_type == 0) { - if (verbose){ + if (verbose) { message("Assigning season from SAMPLE_MONTH.") } Pdata[, "season"] <- utils::type.convert(as.is = TRUE, Pdata$SAMPLE_MONTH) - } # End if # Petrale seasons if (season_type == 1) { - if (verbose){ + if (verbose) { message("Assigning seasons for Petrale; winter == 1, summer == 2.") } Pdata[, "season"] <- ifelse(Pdata[, "SAMPLE_MONTH"] %in% c(11:12, 1:2), - 1, 2) + 1, 2 + ) } # End if Petrale if (!is.null(yearUp)) { Pdata$fishyr[Pdata$SAMPLE_MONTH %in% yearUp] <- Pdata$fishyr[Pdata$SAMPLE_MONTH %in% yearUp] + 1 - if (verbose){ - message("Incremented fishyr for months ", - paste(yearUp, collapse = ", "), "to the next year.") + if (verbose) { + message( + "Incremented fishyr for months ", + paste(yearUp, collapse = ", "), "to the next year." + ) } - } # End if yearUp if (!is.null(yearDown)) { Pdata$fishyr[Pdata$SAMPLE_MONTH %in% yearDown] <- Pdata$fishyr[Pdata$SAMPLE_MONTH %in% yearDown] - 1 - if (verbose){ - message("Decremented fishyr for months ", - paste(yearDown, collapse = ", "), "to the previous year.") + if (verbose) { + message( + "Decremented fishyr for months ", + paste(yearDown, collapse = ", "), "to the previous year." + ) } - } # End if yearDown if (plotResults) { tmp <- table(Pdata[, c("season", "SAMPLE_YEAR")]) - graphics::barplot(tmp, col = grDevices::rainbow(NROW(tmp)), + graphics::barplot(tmp, + col = grDevices::rainbow(NROW(tmp)), legend.text = paste("Season", rownames(tmp)), main = unique(Pdata$SPID), xlab = "Year", ylab = "Count", - bty = "n") + bty = "n" + ) } # End if plotResults return(Pdata) - } diff --git a/R/getState.R b/R/getState.R index 9317313..5b69a22 100644 --- a/R/getState.R +++ b/R/getState.R @@ -50,18 +50,20 @@ #' @examples #' data <- data.frame( #' AGENCY_CODE = rep(c("W", "O", "C"), each = 2), -#' info = 1:6) +#' info = 1:6 +#' ) #' testthat::expect_true( -#' all(getState(data)[["state"]] == rep(c("WA", "OR", "CA"), each = 2)) +#' all(getState(data)[["state"]] == rep(c("WA", "OR", "CA"), each = 2)) #' ) #' -getState <- function (Pdata, - source = c("AGENCY_CODE", "SOURCE_AGID"), - verbose = TRUE) { - +getState <- function(Pdata, + source = c("AGENCY_CODE", "SOURCE_AGID"), + verbose = TRUE) { if (any(source %in% c("PSMFC_CATCH_AREA_CODE", "PSMFC_ARID"))) { - stop("'PSMFC_CATCH_AREA_CODE' and 'PSMFC_ARID' are no longer supported ", - "inputs to getState(source = ).") + stop( + "'PSMFC_CATCH_AREA_CODE' and 'PSMFC_ARID' are no longer supported ", + "inputs to getState(source = )." + ) } source <- match.arg(source, several.ok = FALSE) colid <- match(source, colnames(Pdata)) @@ -71,24 +73,27 @@ getState <- function (Pdata, Pdata$state <- as.character(Pdata[, source]) - Pdata[, "state"] <- vapply(Pdata[, "state"], FUN = switch, + Pdata[, "state"] <- vapply(Pdata[, "state"], + FUN = switch, FUN.VALUE = "character", C = "CA", CalCOM = "CA", CALCOM = "CA", O = "OR", W = "WA", - "UNK") + "UNK" + ) states <- c("OR", "CA", "WA") nostate <- sum(!Pdata[, "state"] %in% states) if (verbose) { - message("\nThere are ", nostate, + message( + "\nThere are ", nostate, " records for which the state (i.e., 'CA', 'OR', 'WA')", - "\ncould not be assigned and were labeled as 'UNK'.") + "\ncould not be assigned and were labeled as 'UNK'." + ) utils::capture.output(type = "message", table(Pdata[, "state"])) } # End if verbose return(Pdata) - } diff --git a/R/getWLpars.R b/R/getWLpars.R index 4ec7bf6..af6f904 100644 --- a/R/getWLpars.R +++ b/R/getWLpars.R @@ -35,7 +35,6 @@ getWLpars <- function(data, col.length = "lengthcm", col.weight = "weightkg", verbose = TRUE) { - col.length <- tolower(col.length) col.weight <- tolower(col.weight) colnames(data) <- tolower(colnames(data)) @@ -50,29 +49,34 @@ getWLpars <- function(data, dims <- dim(data) data <- data[ !is.na(data[[col.weight]]) & - !is.na(data[[col.length]]), ] + !is.na(data[[col.length]]), + ] if (verbose) { - message("Calculating the weight-length relationship from ", + message( + "Calculating the weight-length relationship from ", nrow(data), "\nfish because ", dims[1] - nrow(data), - " fish did not have empirical weights and lengths.") + " fish did not have empirical weights and lengths." + ) } mresults <- tibble::lst( female = . %>% dplyr::filter(sex == "F"), male = . %>% dplyr::filter(sex == "M"), all = . %>% dplyr::filter(sex %in% c(NA, "F", "M", "U", "H")) - ) %>% - purrr::map_dfr(~ tidyr::nest(.x(data), data = everything()), .id = "group") %>% - dplyr::mutate( - fits = purrr::map(data, ~ stats::lm(log(weight) ~ log(length_cm), data = .x)) + ) %>% + purrr::map_dfr(~ tidyr::nest(.x(data), data = everything()), .id = "group") %>% + dplyr::mutate( + fits = purrr::map(data, ~ stats::lm(log(weight) ~ log(length_cm), data = .x)) ) - WLresults <- mresults %>% dplyr::summarize( - group = group, - median_intercept = purrr::map_dbl(fits, ~ exp(.x$coefficients[1])), - SD = purrr::map_dbl(fits, ~ sd(.x$residuals)), - A = purrr::map_dbl(fits, ~ exp(.x$coefficients[1])*exp(0.5*sd(.x$residuals)^2)), - B = purrr::map_dbl(fits, ~ .x$coefficients[2]) - ) %>% data.frame + WLresults <- mresults %>% + dplyr::summarize( + group = group, + median_intercept = purrr::map_dbl(fits, ~ exp(.x$coefficients[1])), + SD = purrr::map_dbl(fits, ~ sd(.x$residuals)), + A = purrr::map_dbl(fits, ~ exp(.x$coefficients[1]) * exp(0.5 * sd(.x$residuals)^2)), + B = purrr::map_dbl(fits, ~ .x$coefficients[2]) + ) %>% + data.frame() if (verbose) { message("Weight-Length model results by SEX:") diff --git a/R/get_codelist.R b/R/get_codelist.R index cb96c67..ceff16c 100644 --- a/R/get_codelist.R +++ b/R/get_codelist.R @@ -52,14 +52,18 @@ get_codelist <- function(x = c("GRID", "INPFC", "PORT")) { #' get_codelist.GRID <- function(x) { url <- "https://pacfin.psmfc.org/pacfin_pub/data_rpts_pub/code_lists/gr.txt" - all <- utils::read.fwf(url(url), skip = 5, widths = c(5, 5, 6, 10, 38, 9), - blank.lines.skip = TRUE) + all <- utils::read.fwf(url(url), + skip = 5, widths = c(5, 5, 6, 10, 38, 9), + blank.lines.skip = TRUE + ) colnames(all) <- toupper(gsub("^\\s+|\\s+$| Name", "", all[1, ])) all <- all[c(-1, -2), ] - all <- all[-1 * seq(grep("\\.\\.\\.", all[,3]), NROW(all)), ] + all <- all[-1 * seq(grep("\\.\\.\\.", all[, 3]), NROW(all)), ] all <- all[!grepl("^\\s+$", all[, 1]), ] - all[ , c("TYPE", "GRID", "GROUP")] <- t(apply(all[ , c("TYPE", "GRID", "GROUP")], 1, - function(x) gsub("^\\s*|\\s*$", "", x))) + all[, c("TYPE", "GRID", "GROUP")] <- t(apply( + all[, c("TYPE", "GRID", "GROUP")], 1, + function(x) gsub("^\\s*|\\s*$", "", x) + )) all <- all[, -which(colnames(all) == "ENTERED")] return(all) } diff --git a/R/getweight.R b/R/getweight.R index b1c8ca7..af9b907 100644 --- a/R/getweight.R +++ b/R/getweight.R @@ -34,7 +34,6 @@ getweight <- function(length, unit.out = c("lb", "kg"), weight, unit.in) { - unit.out <- match.arg(unit.out, several.ok = FALSE) #### Option # 1 ... Change units of weight @@ -51,17 +50,20 @@ getweight <- function(length, } } if (any(unit.in == "H", na.rm = TRUE)) { - message("FISH_WEIGHT units of H are changed to G for ", - sum(unit.in == "H", na.rm = TRUE), " fish.") + message( + "FISH_WEIGHT units of H are changed to G for ", + sum(unit.in == "H", na.rm = TRUE), " fish." + ) unit.in[unit.in == "H"] <- "G" } transformweight <- weight * mapply(switch, unit.in, - MoreArgs = list( - G = 0.00220462, - KG = 2.20462, - UNK = 0.00220462, - 0.00220462) - ) + MoreArgs = list( + G = 0.00220462, + KG = 2.20462, + UNK = 0.00220462, + 0.00220462 + ) + ) if (unit.out == "kg") { transformweight <- transformweight * 0.453592 } @@ -71,8 +73,12 @@ getweight <- function(length, #### Option # 2 ... a * (length / 10)^b * 2.20462 [length = cm; weight = kg] #### Checks stopifnot(all(sex %in% c(NA, "U", "F", "M", "H"))) - if (length(length) != length(sex)) stop("The vectors, length and", - " sex, must be equal in length.") + if (length(length) != length(sex)) { + stop( + "The vectors, length and", + " sex, must be equal in length." + ) + } if (is.matrix(pars)) pars <- data.frame(pars) if ((!"H" %in% row.names(pars)) & "H" %in% sex & "all" %in% row.names(pars)) { pars["H", ] <- pars["all", ] @@ -95,4 +101,4 @@ getweight <- function(length, #### return return(calcweight) - } +} diff --git a/R/plotCleaned.R b/R/plotCleaned.R index ff59ca6..4f15bb3 100644 --- a/R/plotCleaned.R +++ b/R/plotCleaned.R @@ -16,20 +16,21 @@ #' * PacFIN_comp_INPFC.png #' * PacFIN_comp_lengthvage.png #' @author Andi Stephens, Kelli F. Johnson -#' +#' #' @export #' #' @seealso This function is called by [cleanPacFIN] and heavily #' relies on [getGearGroup] to create gear categories. #' -plotCleaned <- function (Pdata, - savedir = getwd()) { - +plotCleaned <- function(Pdata, + savedir = getwd()) { #### Checks SPID <- sort(unique(Pdata$SPID)) if (length(SPID) > 1) { - warning("plotCleaned is only meant to work with one species;", - "\nfigures will be a summary of all species in your data.") + warning( + "plotCleaned is only meant to work with one species;", + "\nfigures will be a summary of all species in your data." + ) } geargroups <- ifelse(length(Pdata$geargroup) > 0, TRUE, FALSE) @@ -37,92 +38,121 @@ plotCleaned <- function (Pdata, #### Plot grDevices::png(file.path(savedir, "PacFIN_comp_Nbystate.png")) on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) - graphics::par(mfrow = c(2, 1), + graphics::par( + mfrow = c(2, 1), oma = c(1, 1, 3, 0.25), mar = c(0.5, 3.25, 0, 0), - mgp = c(1.5, 0.5, 0)) + mgp = c(1.5, 0.5, 0) + ) graphics::barplot(stats::xtabs(!is.na(Pdata$length) ~ Pdata$state + Pdata$fishyr), col = grDevices::rainbow(length(unique(Pdata$state))), legend.text = TRUE, xaxt = "n", xlab = "", ylab = "Length samples per state", - args.legend = list(x = "topleft", bty = "n")) + args.legend = list(x = "topleft", bty = "n") + ) graphics::barplot(stats::xtabs(!is.na(Pdata$Age) ~ Pdata$state + Pdata$fishyr), col = grDevices::rainbow(length(unique(Pdata$state))), legend.text = FALSE, xlab = "Year", ylab = "Age samples per state", - args.legend = list(x = "topleft", bty = "n")) - + args.legend = list(x = "topleft", bty = "n") + ) + grDevices::png(file.path(savedir, "PacFIN_comp_distributions.png")) on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) - graphics::par(mfrow = c(2, 1), + graphics::par( + mfrow = c(2, 1), oma = c(1, 1, 3, 0.25), mar = c(0.5, 3.25, 0, 0), - mgp = c(1.5, 0.5, 0)) + mgp = c(1.5, 0.5, 0) + ) graphics::boxplot(Pdata$lengthcm ~ Pdata$fishyr, xlab = "", ylab = "Length (cm)", xaxt = "n", - frame.plot = TRUE, ylim = c(0, max(Pdata$lengthcm, na.rm = TRUE))) + frame.plot = TRUE, ylim = c(0, max(Pdata$lengthcm, na.rm = TRUE)) + ) graphics::boxplot(Pdata$Age ~ Pdata$fishyr, xlab = "Year", ylab = "Age", - frame.plot = TRUE, ylim = c(0, max(Pdata$Age, na.rm = TRUE))) + frame.plot = TRUE, ylim = c(0, max(Pdata$Age, na.rm = TRUE)) + ) grDevices::png(file.path(savedir, "PacFIN_comp_NbyGRID.png")) on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) - graphics::par(mfrow = c(2, 1), + graphics::par( + mfrow = c(2, 1), oma = c(1, 1, 3, 0.25), mar = c(0.5, 3.25, 0, 0), - mgp = c(1.5, 0.5, 0)) + mgp = c(1.5, 0.5, 0) + ) nGRID <- length(unique(Pdata$GRID)) graphics::barplot(stats::xtabs(!is.na(Pdata$length) ~ Pdata$GRID + Pdata$fishyr), col = grDevices::rainbow(nGRID), legend.text = TRUE, xlab = "", xaxt = "n", ylab = "Length samples per gear", - args.legend = list(x = "topleft", bty = "n", ncol = ceiling(nGRID / 4))) + args.legend = list(x = "topleft", bty = "n", ncol = ceiling(nGRID / 4)) + ) graphics::barplot(stats::xtabs(!is.na(Pdata$Age) ~ Pdata$GRID + Pdata$fishyr), col = grDevices::rainbow(nGRID), legend.text = FALSE, xlab = "Year", ylab = "Age samples per gear", - args.legend = list(x = "topleft", bty = "n", ncol = ceiling(nGRID / 4))) + args.legend = list(x = "topleft", bty = "n", ncol = ceiling(nGRID / 4)) + ) if (!all(is.na(Pdata[, "DEPTH_AVG"]))) { grDevices::png(file.path(savedir, "PacFIN_comp_depth.png")) on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) - graphics::boxplot(Pdata$DEPTH_AVG ~ Pdata$fishyr, ylab = expression(bar(Depth)), - frame.plot = FALSE, ylim = c(0, max(Pdata$DEPTH_AVG, na.rm = TRUE))) + graphics::boxplot(Pdata$DEPTH_AVG ~ Pdata$fishyr, + ylab = expression(bar(Depth)), + frame.plot = FALSE, ylim = c(0, max(Pdata$DEPTH_AVG, na.rm = TRUE)) + ) } if (geargroups) { grDevices::png(file.path(savedir, "PacFIN_comp_geargroup.png")) on.exit(grDevices::dev.off(), add = TRUE, after = FALSE) - graphics::par(mfrow = c(2, 1), + graphics::par( + mfrow = c(2, 1), oma = c(1, 1, 3, 0.25), mar = c(0.5, 3.25, 0, 0), - mgp = c(1.5, 0.5, 0)) + mgp = c(1.5, 0.5, 0) + ) graphics::barplot(stats::xtabs(!is.na(Pdata$length) ~ Pdata$geargroup + Pdata$fishyr), col = grDevices::rainbow(length(unique(Pdata$geargroup))), legend.text = TRUE, xaxt = "n", xlab = "", ylab = "Length samples per gear group", - args.legend = list(x = "topleft", bty = "n")) + args.legend = list(x = "topleft", bty = "n") + ) graphics::barplot(stats::xtabs(!is.na(Pdata$Age) ~ Pdata$geargroup + Pdata$fishyr), col = grDevices::rainbow(length(unique(Pdata$geargroup))), legend.text = FALSE, xlab = "Year", ylab = "Age samples per gear group", - args.legend = list(x = "topleft", bty = "n")) + args.legend = list(x = "topleft", bty = "n") + ) } # End if #### ggplots nn <- grDevices::rainbow(length(unique(Pdata[["state"]]))) - gg <- ggplot2::ggplot(data = Pdata, - ggplot2::aes(x = .data[["PSMFC_ARID"]], - fill = factor(.data[["state"]]))) + - ggplot2::geom_bar() + ggplot2::theme_bw() + + gg <- ggplot2::ggplot( + data = Pdata, + ggplot2::aes( + x = .data[["PSMFC_ARID"]], + fill = factor(.data[["state"]]) + ) + ) + + ggplot2::geom_bar() + + ggplot2::theme_bw() + ggplot2::labs(fill = "State", x = "PSMFC area", y = "Count") + ggplot2::scale_fill_manual(values = nn) ggplot2::ggsave(gg, file = file.path(savedir, "PacFIN_comp_PSMFC.png"), - width = 6, height = 6, dpi = 500) - gg <- ggplot2::ggplot(data = Pdata, - ggplot2::aes(x = .data[["lengthcm"]], - y = .data[["Age"]])) + - ggplot2::geom_point() + ggplot2::theme_bw() + + width = 6, height = 6, dpi = 500 + ) + gg <- ggplot2::ggplot( + data = Pdata, + ggplot2::aes( + x = .data[["lengthcm"]], + y = .data[["Age"]] + ) + ) + + ggplot2::geom_point() + + ggplot2::theme_bw() + ggplot2::labs(x = "Length (cm)", y = "Age (year)") suppressWarnings(ggplot2::ggsave(gg, file = file.path(savedir, "PacFIN_comp_lengthvage.png"), - width = 6, height = 6, dpi = 500)) - + width = 6, height = 6, dpi = 500 + )) } # End function plotCleaned diff --git a/R/plotRawData.R b/R/plotRawData.R index c333547..6c05b00 100644 --- a/R/plotRawData.R +++ b/R/plotRawData.R @@ -1,10 +1,10 @@ ############################################################################# #' #' Diagnostic plots and summaries for a raw PacFIN dataset pre-filtering. -#' -#' \code{plotRawData} creates a set of diagnostic plots and summaries, writing +#' +#' \code{plotRawData} creates a set of diagnostic plots and summaries, writing #' pdfs and a text file in addition to plotting onscreen and console. -#' +#' #' \subsection{Workflow}{ #' Run \code{plotRawData} to visualize and summarize the PacFIN data prior to #' running \code{\link{cleanPacFIN}}. @@ -17,87 +17,82 @@ #' #' @details #' Will create a filename from the species ID if one is not provided. -#' +#' ############################################################################## plotRawData <- function(rawData, fname = NULL) { + cat("\nRunning diagnostics\n\n") - cat( "\nRunning diagnostics\n\n" ) - - if ( is.null(fname) ) { - + if (is.null(fname)) { # Set up filenames for txt, pdf - species = sort(unique(rawData$SPID)) - pdffile = paste( "Diags.", species, ".pdf", sep="") - txtfile = paste( "Diags.", species, ".txt", sep="") - + species <- sort(unique(rawData$SPID)) + pdffile <- paste("Diags.", species, ".pdf", sep = "") + txtfile <- paste("Diags.", species, ".txt", sep = "") } else { # Remove the extension fname <- gsub("\\.[a-zA-Z]{3}$", "", fname) - pdffile = paste(fname, ".pdf", sep="") - txtfile = paste(fname, ".txt", sep="") - - + pdffile <- paste(fname, ".pdf", sep = "") + txtfile <- paste(fname, ".txt", sep = "") } # End ifelse - cat( "Plots will be written to", pdffile, "\n" ) - cat( "Summaries will be written to", txtfile, "\n" ) - - sink(file=txtfile,split=T, append=T) + cat("Plots will be written to", pdffile, "\n") + cat("Summaries will be written to", txtfile, "\n") + + sink(file = txtfile, split = T, append = T) # Develop statistics of interest - len = rawData[!is.na(rawData$FISH_LENGTH),] - len$len = floor(len$FISH_LENGTH/10) - len$depth_mid = (len$DEPTH_MIN+len$DEPTH_MAX)/2 - ltows = len[!duplicated(len$SAMPLE_NO),] + len <- rawData[!is.na(rawData$FISH_LENGTH), ] + len$len <- floor(len$FISH_LENGTH / 10) + len$depth_mid <- (len$DEPTH_MIN + len$DEPTH_MAX) / 2 + ltows <- len[!duplicated(len$SAMPLE_NO), ] - meanLen.yr = tapply(len$len,list(len$SAMPLE_YEAR),mean) - meanLen = tapply(len$len,list(len$SAMPLE_NO,len$SAMPLE_YEAR),mean) + meanLen.yr <- tapply(len$len, list(len$SAMPLE_YEAR), mean) + meanLen <- tapply(len$len, list(len$SAMPLE_NO, len$SAMPLE_YEAR), mean) - age = rawData[!is.na(rawData$FISH_AGE_YEARS_FINAL),] - age$Age = age$FISH_AGE_YEARS_FINAL - atows = age[!duplicated(age$SAMPLE_NO),] - meanAge = tapply(age$Age,list(age$SAMPLE_NO,age$SAMPLE_YEAR),mean) + age <- rawData[!is.na(rawData$FISH_AGE_YEARS_FINAL), ] + age$Age <- age$FISH_AGE_YEARS_FINAL + atows <- age[!duplicated(age$SAMPLE_NO), ] + meanAge <- tapply(age$Age, list(age$SAMPLE_NO, age$SAMPLE_YEAR), mean) # Print tables - #cat("Lengths for which FISH_LENGTH_TYPE is T: ") - #print(len[len$FISH_LENGTH_TYPE=="T",]) - #cat("\n\n") + # cat("Lengths for which FISH_LENGTH_TYPE is T: ") + # print(len[len$FISH_LENGTH_TYPE=="T",]) + # cat("\n\n") cat("Records per SAMPLE_YEAR\n\n") - print(table(rawData$SAMPLE_YEAR,useNA="ifany")) + print(table(rawData$SAMPLE_YEAR, useNA = "ifany")) cat("\n\n") cat("FISH_LENGTH_TYPE\n") - print(table(rawData$FISH_LENGTH_TYPE,useNA="ifany")) + print(table(rawData$FISH_LENGTH_TYPE, useNA = "ifany")) cat("\n\n") cat("FISH_LENGTH\n") - print(table(rawData$FISH_LENGTH,useNA="ifany")) + print(table(rawData$FISH_LENGTH, useNA = "ifany")) cat("\n\n") cat("GEAR vs GRID\n") - print(table(len$GEAR,len$GRID)) + print(table(len$GEAR, len$GRID)) cat("\n\n") cat("FISH_LENGTH for lengthed fish\n") - print(table(len$FISH_LENGTH_TYPE,useNA="ifany")) + print(table(len$FISH_LENGTH_TYPE, useNA = "ifany")) cat("\n\n") cat("SAMPLE_YEAR vs SOURCE_AGID for lengthed fish\n") - print(table(len$SAMPLE_YEAR,len$SOURCE_AGID)) + print(table(len$SAMPLE_YEAR, len$SOURCE_AGID)) cat("\n\n") cat("Difference between FISH_LENGTH and floor(FISH_LENGTH)\n") - print(table(len$FISH_LENGTH-floor(len$FISH_LENGTH))) + print(table(len$FISH_LENGTH - floor(len$FISH_LENGTH))) cat("\n\n") cat("Difference between FISH_LENGTH/10 and floor(FISH_LENGTH/10)\n") - print(table(round(len$FISH_LENGTH/10-floor(len$FISH_LENGTH/10),1))) + print(table(round(len$FISH_LENGTH / 10 - floor(len$FISH_LENGTH / 10), 1))) cat("\n\n") cat("DEPTH_AVG for lengthed fish\n") @@ -105,11 +100,11 @@ plotRawData <- function(rawData, cat("\n\n") cat("SAMPLE_YEAR vs. SOURCE_AGID for SAMPLE_NOs with lengthed fish\n") - print(table(ltows$SAMPLE_YEAR,ltows$SOURCE_AGID)) + print(table(ltows$SAMPLE_YEAR, ltows$SOURCE_AGID)) cat("\n\n") cat("DEPTH_AVG for SAMPLE_NOs with lengthed fish\n") - print(table(is.na(ltows$DEPTH_AVG),useNA="ifany")) + print(table(is.na(ltows$DEPTH_AVG), useNA = "ifany")) cat("\n\n") cat("Number of aged fish\n") @@ -117,11 +112,11 @@ plotRawData <- function(rawData, cat("\n\n") cat("SAMPLE_YEAR vs. SOURCE_AGID for SAMPLE_NOs with aged fish\n") - print(table(atows$SAMPLE_YEAR,atows$SOURCE_AGID)) + print(table(atows$SAMPLE_YEAR, atows$SOURCE_AGID)) cat("\n\n") cat("SAMPLE_YEAR vs. SOURCE_AGID for aged fish\n") - print(table(age$SAMPLE_YEAR,age$SOURCE_AGID)) + print(table(age$SAMPLE_YEAR, age$SOURCE_AGID)) cat("\n\n") cat("age vs. ageX for aged fish\n") @@ -140,26 +135,26 @@ plotRawData <- function(rawData, grDevices::pdf(pdffile) - graphics::par(mfrow=c(2,2)) + graphics::par(mfrow = c(2, 2)) - graphics::hist(len$len,nclass=30, xlab="", main="FISH_LENGTH") + graphics::hist(len$len, nclass = 30, xlab = "", main = "FISH_LENGTH") - graphics::barplot(table(10*round(len$FISH_LENGTH/10-floor(len$FISH_LENGTH/10),1)), - xlab="Difference in rounded and floored lengths") + graphics::barplot(table(10 * round(len$FISH_LENGTH / 10 - floor(len$FISH_LENGTH / 10), 1)), + xlab = "Difference in rounded and floored lengths" + ) - plot(len$FISH_LENGTH,len$FORK_LENGTH,pch=16, xlab="FISH_LENGTH", ylab="FORK_LENGTH") + plot(len$FISH_LENGTH, len$FORK_LENGTH, pch = 16, xlab = "FISH_LENGTH", ylab = "FORK_LENGTH") - plot(len$DEPTH_AVG,len$depth_mid,xlim=c(0,400),ylim=c(0,400), xlab="DEPTH_AVG", ylab="Depth_mid") - graphics::abline(a=0,b=1) + plot(len$DEPTH_AVG, len$depth_mid, xlim = c(0, 400), ylim = c(0, 400), xlab = "DEPTH_AVG", ylab = "Depth_mid") + graphics::abline(a = 0, b = 1) - graphics::hist(ltows$DEPTH_AVG, xlab="", main="DEPTH_AVG") + graphics::hist(ltows$DEPTH_AVG, xlab = "", main = "DEPTH_AVG") - graphics::hist(age$Age,nclass=30, xlab="", main="Age") + graphics::hist(age$Age, nclass = 30, xlab = "", main = "Age") - graphics::par(mfrow=c(2,1)) - graphics::boxplot(as.list(as.data.frame(meanLen)),varwidth=T,main="Mean length") - graphics::boxplot(as.list(as.data.frame(meanAge)),varwidth=T,main="Mean age") + graphics::par(mfrow = c(2, 1)) + graphics::boxplot(as.list(as.data.frame(meanLen)), varwidth = T, main = "Mean length") + graphics::boxplot(as.list(as.data.frame(meanAge)), varwidth = T, main = "Mean age") grDevices::dev.off() - } # End plotRawData diff --git a/R/plotStrat.R b/R/plotStrat.R index 1ee8912..45ee712 100644 --- a/R/plotStrat.R +++ b/R/plotStrat.R @@ -1,7 +1,7 @@ #' Plot Length Distributions with Aged and All Fish -#' +#' #' todo: document -#' +#' #' @param data A data frame #' @param dir The directory you want to print the plots #' @param npages The number of pages you want the plots split over. @@ -20,34 +20,40 @@ plotStrat <- function(data, col.length = "lengthcm", height = 10, width = 10) { - - splits <- split(unique(data$year)[order(unique(data$year))], - ggplot2::cut_number(unique(data$year)[order(unique(data$year))], npages)) + splits <- split( + unique(data$year)[order(unique(data$year))], + ggplot2::cut_number(unique(data$year)[order(unique(data$year))], npages) + ) data[["fleet"]] <- factor(data[[col.fleet]]) data[["area"]] <- factor(data[[col.area]]) data[["Age"]] <- as.factor(!is.na(data[[col.age]])) for (ii_g in c(stats::formula("area ~ fleet"), stats::formula("fleet ~ area"))) { - grDevices::pdf(file = file.path(dir, paste0("lengthedages_", - gsub("~", "", paste(ii_g, collapse = "")), ".pdf")), - height = height, width = width) - for(ii in seq_along(splits)) { + grDevices::pdf( + file = file.path(dir, paste0( + "lengthedages_", + gsub("~", "", paste(ii_g, collapse = "")), ".pdf" + )), + height = height, width = width + ) + for (ii in seq_along(splits)) { plotmea <- data[data$year %in% splits[[ii]], , drop = FALSE] if (nrow(plotmea) == 0) next - gg <- ggplot2::ggplot(plotmea, - ggplot2::aes( - x = .data[[col.length]], - y = year, - group = interaction(year,Age), - fill = Age + gg <- ggplot2::ggplot( + plotmea, + ggplot2::aes( + x = .data[[col.length]], + y = year, + group = interaction(year, Age), + fill = Age ) ) + - ggridges::geom_density_ridges2(scale = 5, alpha = 0.7) + - ggplot2::facet_grid(ii_g) + - ggplot2::theme_bw() + - ggplot2::guides(fill = guide_legend(title = "Aged")) + - ggplot2::theme( - strip.background = element_rect(colour = "black", fill = "white"), - legend.position = "top" + ggridges::geom_density_ridges2(scale = 5, alpha = 0.7) + + ggplot2::facet_grid(ii_g) + + ggplot2::theme_bw() + + ggplot2::guides(fill = guide_legend(title = "Aged")) + + ggplot2::theme( + strip.background = element_rect(colour = "black", fill = "white"), + legend.position = "top" ) print(gg) } diff --git a/R/plotWL.R b/R/plotWL.R index 8ba6f67..1ac3c2b 100644 --- a/R/plotWL.R +++ b/R/plotWL.R @@ -26,15 +26,23 @@ plotWL <- function(length, sex <- rep("all", length = length(length)) } data <- data.frame(length, sex, weight, "pred" = weight.calc)[ - order(length), ] - gg <- ggplot2::ggplot(data = data, - ggplot2::aes(x = .data[["length"]], y = .data[["weight"]], - col = .data[["sex"]])) + + order(length), + ] + gg <- ggplot2::ggplot( + data = data, + ggplot2::aes( + x = .data[["length"]], y = .data[["weight"]], + col = .data[["sex"]] + ) + ) + ggplot2::geom_point(pch = 21, alpha = 0.8) + ggplot2::geom_line(ggplot2::aes(y = .data[["pred"]]), - lwd = 1.2) + + lwd = 1.2 + ) + ggplot2::xlab(xlab) + ggplot2::ylab(ylab) + - ggplot2::theme_bw() + scale_colour_grey() + scale_fill_grey() + ggplot2::theme_bw() + + scale_colour_grey() + + scale_fill_grey() return(gg) } diff --git a/R/sql-.R b/R/sql-.R index 5f2c9b8..7370c0c 100644 --- a/R/sql-.R +++ b/R/sql-.R @@ -37,8 +37,7 @@ sql_area <- function() { sqlcall <- glue::glue(" SELECT * FROM PACFIN.BDS_AR; - " - ) + ") sqlcall <- gsub("\\n", " ", sqlcall) return(sqlcall) } @@ -62,8 +61,7 @@ sql_bds <- function(pacfin_species_code) { SELECT * FROM PACFIN_MARTS.COMPREHENSIVE_BDS_COMM WHERE REGEXP_LIKE (PACFIN_SPECIES_CODE, {spid}); - " - ) + ") sqlcall <- gsub("\\n", " ", sqlcall) return(sqlcall) } @@ -85,10 +83,9 @@ sql_catch <- function(pacfin_species_code, council_code = "P") { sqlcall <- glue::glue(" SELECT * FROM PACFIN_MARTS.COMPREHENSIVE_FT - WHERE PACFIN_SPECIES_CODE = ANY ({species}) + WHERE PACFIN_SPECIES_CODE = ANY ({species}) AND COUNCIL_CODE = ANY ({council}) - " - ) + ") sqlcall <- gsub("\\n", " ", sqlcall) return(sqlcall) } @@ -100,8 +97,7 @@ sql_species <- function() { SELECT DISTINCT PACFIN_SPECIES_CODE, PACFIN_SPECIES_COMMON_NAME FROM PACFIN_MARTS.COMPREHENSIVE_FT ORDER BY PACFIN_SPECIES_COMMON_NAME, PACFIN_SPECIES_CODE; - " - ) + ") sqlcall <- gsub("\\n", " ", sqlcall) return(sqlcall) } @@ -123,8 +119,7 @@ sql_check_FINAL_FISH_AGE_IN_YEARS <- function() { WHERE AGE_IN_YEARS is not null and FINAL_FISH_AGE_IN_YEARS is null group by PACFIN_SPECIES_CODE, AGENCY_CODE ORDER by PACFIN_SPECIES_CODE, AGENCY_CODE; - " - ) + ") sqlcall <- gsub("\\n", " ", sqlcall) return(sqlcall) } diff --git a/R/tableSample.R b/R/tableSample.R index 5a47c4b..7ed594b 100644 --- a/R/tableSample.R +++ b/R/tableSample.R @@ -26,32 +26,32 @@ tableSample <- function(Pdata, fname = paste0("fishery_", comps, "_samples.csv"), strat = "SOURCE_AGID", comps = c("LEN", "AGE"), remove_yrs = NULL) { - Pdata$strat <- apply(Pdata[, strat, drop = FALSE], 1, paste0, collapse = ".") comps <- match.arg(comps, several.ok = FALSE) - if (comps == "LEN"){ - temp = Pdata[!is.na(Pdata$FISH_LENGTH), ] - } - - if (comps == "AGE"){ - temp = Pdata[!is.na(Pdata$Age), ] - } + if (comps == "LEN") { + temp <- Pdata[!is.na(Pdata$FISH_LENGTH), ] + } + + if (comps == "AGE") { + temp <- Pdata[!is.na(Pdata$Age), ] + } - if(!is.null(remove_yrs)){ - temp = temp[!temp$SAMPLE_YEAR %in% remove_yrs, ] - } + if (!is.null(remove_yrs)) { + temp <- temp[!temp$SAMPLE_YEAR %in% remove_yrs, ] + } - Ntow = table(temp$SAMPLE_YEAR, temp$strat, !duplicated(as.character(temp$SAMPLE_NO)))[,,"TRUE"] - Nfish = table(temp$SAMPLE_YEAR, temp$strat) + Ntow <- table(temp$SAMPLE_YEAR, temp$strat, !duplicated(as.character(temp$SAMPLE_NO)))[, , "TRUE"] + Nfish <- table(temp$SAMPLE_YEAR, temp$strat) - samples = rownames(Ntow); names = "Year" - for (a in colnames(Ntow)){ - get = cbind(Ntow[,a], Nfish[,a]) - samples = cbind(samples, get) - names = c(names, paste0(a, ".tows"), paste0(a, ".fish")) - } - colnames(samples) = names + samples <- rownames(Ntow) + names <- "Year" + for (a in colnames(Ntow)) { + get <- cbind(Ntow[, a], Nfish[, a]) + samples <- cbind(samples, get) + names <- c(names, paste0(a, ".tows"), paste0(a, ".fish")) + } + colnames(samples) <- names - utils::write.csv(samples, file = fname, row.names=FALSE) + utils::write.csv(samples, file = fname, row.names = FALSE) return(invisible(samples)) -} \ No newline at end of file +} diff --git a/R/writeComps.R b/R/writeComps.R index 64a5d57..9d5693a 100644 --- a/R/writeComps.R +++ b/R/writeComps.R @@ -1,45 +1,45 @@ ########################################################################## #' #' Write out composition data formatted for Stock Synthesis. -#' +#' #' @description #' Write out composition data to a file, binning the data as specified. -#' +#' #' \subsection{Workflow}{ #' PacFIN data should first be stratified using \code{\link{getComps}}, #' before using \code{writeComps}. #' } -#' -#' +#' +#' #' @export -#' +#' #' @param inComps A dataframe generated as described in Workflow, above. -#' +#' #' @template fname -#' +#' #' @param abins Bins to use for ages. Default is the data bins. #' @param lbins Bins to use for lengths. Default is the data bins. -#' +#' #' @param maxAge A numeric value specifying the maximum age of fish that #' should be included in the composition data, unless \code{dummybins = TRUE}, #' then those fish will be included in a plus group which you can investigate #' later. Note that \code{maxAge} is only used if \code{abins = NULL}, otherwise #' fish are binned according to user specified bins irregardless of \code{maxAge}. -#' -#' @param month Month for all observations. Defaults to 7. If input has multiple +#' +#' @param month Month for all observations. Defaults to 7. If input has multiple #' seasons, this must be a vector of equal length to the maximum seasons where #' the order of months in the vector will be assigned to season in ascending order. -#' For example, if there are two seasons and the month = c(1, 7) season 1 will be +#' For example, if there are two seasons and the month = c(1, 7) season 1 will be #' assigned to month 1 and season 2 to month 7. -#' +#' #' @param partition Used by Stock Synthesis for length- or age-composition data #' where 0 = retained + discarded, 1= discarded, and 2 = retained fish. #' The default is to assume that these fish are retained only. #' The default was changed in 2020 from a value of 0, #' and code should be updated accordingly if you really want 0. -#' +#' #' @param ageErr Defaults to 1. -#' +#' #' @param dummybins A logical value specifying whether data outside of the #' lower and upper \code{abins} or \code{lbins} should be added to dummy bins, #' or be placed in the specified bins. Default is \code{TRUE}. Dummy @@ -54,15 +54,15 @@ #' #' @param overwrite A logical value specifying whether to overwrite an existing #' file if the file associated with the input \code{fname} already exists. -#' +#' #' @template verbose -#' +#' #' @details -#' +#' #' The structure of the input dataframe determines whether #' \code{writeComps} produces age-, length-, or conditional-age-at-length- #' composition data. -#' +#' #' Four sets of composition data are written to a single file specified #' by \code{fname}. These are: #' \itemize{ @@ -71,21 +71,21 @@ #' \item{female data only} #' \item{males and females recombined as unsexed fish} #' } -#' +#' #' The output file is appended to, rather than overwritten, so you may #' want to specify a new filename each time you generate a different #' stratification or bin structure, e.g., "out.1.csv", "out.2.csv". -#' +#' #' Composition data are raw weights rather than proportions. Stock Synthesis #' internally converts these to proportions. The raw weights should be #' examined for anomalies. -#' +#' #' To create proportions use \code{prop.table} on the columns #' containing composition data. -#' +#' #' The columns in the output preceeding 'lengthcm' or 'age' are those that #' were used in stratifying the data. -#' +#' #' \subsection{Reality Checks}{ #' \itemize{ #' \item{Set \code{verbose = TRUE} to follow progress} @@ -93,10 +93,10 @@ #' \item{Examine the raw-weight output for anomalies} #' }} #' @return Appends data to the file given in \code{fname}. -#' +#' #' Conditionally returns a dataframe if the \code{out} argument #' specifies the type of composition to return. -#' +#' #' @author Andi Stephens, Chantel R. Wetzel, Kelli F. Johnson, Ian G. Taylor #' @seealso \code{\link{getComps}}, \code{\link{doSexRatio}} #' @@ -114,12 +114,13 @@ writeComps <- function(inComps, digits = 4, overwrite = TRUE, verbose = FALSE) { - # Check month input vs seasons in data - if("season" %in% names(inComps) && max(inComps[["season"]]) != length(month)) { - stop("Input 'month' should have length equal to the maximum season:", - "\nmonth: ", month, - "\nseasons: ", paste(sort(unique(inComps[["season"]])), collapse = " ")) + if ("season" %in% names(inComps) && max(inComps[["season"]]) != length(month)) { + stop( + "Input 'month' should have length equal to the maximum season:", + "\nmonth: ", month, + "\nseasons: ", paste(sort(unique(inComps[["season"]])), collapse = " ") + ) } # To stop warning of no visible binding b/c assign is used @@ -127,23 +128,29 @@ writeComps <- function(inComps, fComps <- NULL uComps <- NULL - lbins_in <- lbins - abins_in <- abins + lbins_in <- lbins + abins_in <- abins # Which comps are we doing? - Names = names(inComps) - AGE = which(Names == "Age") - LEN = which(Names == "lengthcm") - - if(is.null(fname)){ - if(length(LEN) > 0) { fname = "PacFIN_lengths.out"} - if(length(AGE) > 0) { fname = "PacFIN_ages.out" } - if(length(AGE) > 0 & length(LEN) > 0) { fname = "PacFIN_CAAL.out"} + Names <- names(inComps) + AGE <- which(Names == "Age") + LEN <- which(Names == "lengthcm") + + if (is.null(fname)) { + if (length(LEN) > 0) { + fname <- "PacFIN_lengths.out" + } + if (length(AGE) > 0) { + fname <- "PacFIN_ages.out" + } + if (length(AGE) > 0 & length(LEN) > 0) { + fname <- "PacFIN_CAAL.out" + } } - if (verbose){ + if (verbose) { cat(paste("Writing comps to file", fname, "\n")) - #cat(paste("\nNote that if you didn't run doSexRatio,", + # cat(paste("\nNote that if you didn't run doSexRatio,", # "all unsexed fish disappear at this point.\n\n")) utils::flush.console() } @@ -155,39 +162,41 @@ writeComps <- function(inComps, ) # check for existence of the file before writing anything - if(file.exists(fname)){ - if(overwrite){ - warning("The file ", fname, - "\n exists, and overwrite = TRUE, ", - "so deleting the file before writing new tables.") + if (file.exists(fname)) { + if (overwrite) { + warning( + "The file ", fname, + "\n exists, and overwrite = TRUE, ", + "so deleting the file before writing new tables." + ) file.remove(fname) - }else{ + } else { stop("The file ", fname, "\n exists and overwrite = FALSE.") } utils::flush.console() } # Adding columns in case a sex is not represented in inComps - if(length(inComps$male) == 0) { + if (length(inComps$male) == 0) { inComps$male <- inComps$msamps <- inComps$mtows <- 0 } - if(length(inComps$female) == 0) { + if (length(inComps$female) == 0) { inComps$female <- inComps$fsamps <- inComps$ftows <- 0 } - if(length(inComps$both) == 0) { + if (length(inComps$both) == 0) { inComps$both <- inComps$both <- inComps$both <- 0 } - if(length(inComps$unsexed) == 0){ + if (length(inComps$unsexed) == 0) { inComps$unsexed <- inComps$usamps <- inComps$utows <- 0 } # Fix length bins - if ( !is.null(inComps$lengthcm) ) { - if ( is.null(lbins) ) { + if (!is.null(inComps$lengthcm)) { + if (is.null(lbins)) { if (verbose) { cat("\nNo length bins provided, using data as-is\n\n") } - lbins = sort(unique(inComps$lengthcm)) + lbins <- sort(unique(inComps$lengthcm)) } # End if for lbins # Re-code actual lengths to be lbins @@ -219,69 +228,69 @@ writeComps <- function(inComps, # Fix age bins if (!is.null(inComps$Age)) { - if ( is.null(abins) ) { - if (verbose){ + if (is.null(abins)) { + if (verbose) { cat("\nNo age bins provided, using data as-is\n\n") } - abins = sort(unique(inComps$Age)) - abins = abins[abins < maxAge] + abins <- sort(unique(inComps$Age)) + abins <- abins[abins < maxAge] } # End if for abins # Re-code actual ages to be abins - if (dummybins) { + if (dummybins) { if (min(abins) > 0) { - abins = c(0, abins) - } + abins <- c(0, abins) + } abins <- c(abins, max(abins) + diff(utils::tail(abins, 2)), Inf) - } else { + } else { abins <- c(abins, Inf) } # End if-else dummybins # add extra, dummy bin because all.inside=T - inComps$abin = findInterval(inComps$Age, abins, all.inside = TRUE) + inComps$abin <- findInterval(inComps$Age, abins, all.inside = TRUE) } # End if inComps$ages - AAL = FALSE - if ( length(AGE) > 0 ) { + AAL <- FALSE + if (length(AGE) > 0) { target <- "abin" - STRAT <- AGE - 1 + STRAT <- AGE - 1 KeyNames <- c(Names[1:STRAT]) - inComps$key <- apply(inComps[,KeyNames, drop = FALSE], 1, paste, collapse = " ") + inComps$key <- apply(inComps[, KeyNames, drop = FALSE], 1, paste, collapse = " ") # matrix will be Ages, Ntows, Nsamps. # it gets re-ordered later. NCOLS <- 2 + length(abins) - OutNames <- c(paste("A", abins, sep=""), "Ntows","Nsamps") + OutNames <- c(paste("A", abins, sep = ""), "Ntows", "Nsamps") - if ( length(LEN) > 0 ) { + if (length(LEN) > 0) { AAL <- TRUE STRAT <- AGE - 2 KeyNames <- c(Names[1:STRAT], "lbin") - inComps$key <- apply(inComps[,KeyNames, drop = FALSE], 1, paste, collapse = " ") + inComps$key <- apply(inComps[, KeyNames, drop = FALSE], 1, paste, collapse = " ") # matrix will be Ages, LbinLo, LbinHi, Ntows, Nsamps. # it gets re-ordered later. - NCOLS <- 4 + length(abins) - OutNames <- c(paste("A", abins, sep = ""), "lbin","Ntows","Nsamps") + NCOLS <- 4 + length(abins) + OutNames <- c(paste("A", abins, sep = ""), "lbin", "Ntows", "Nsamps") } # End if } else { target <- "lbin" STRAT <- LEN - 1 KeyNames <- c(Names[1:STRAT]) - inComps$key <- apply(inComps[,KeyNames, drop = FALSE], 1, paste, collapse = " ") + inComps$key <- apply(inComps[, KeyNames, drop = FALSE], 1, paste, collapse = " ") # matrix will have Lbins, Ntows, Nsamps # it gets re-ordered later. NCOLS <- 2 + length(lbins) - OutNames <- c(paste0("L",lbins), "Ntows","Nsamps") + OutNames <- c(paste0("L", lbins), "Ntows", "Nsamps") } # End if-else # Rename columns to be used below - if(!AAL){ + if (!AAL) { names(inComps)[which(names(inComps) == "both")] <- "b" names(inComps)[which(names(inComps) == "female")] <- "f" - names(inComps)[which(names(inComps) == "male")] <- "m" - names(inComps)[which(names(inComps) == "unsexed")]<- "u" + names(inComps)[which(names(inComps) == "male")] <- "m" + names(inComps)[which(names(inComps) == "unsexed")] <- "u" } else { # Overwrite the expansion value to match sample sizes for AAL # This should really be done in the getComps function @@ -289,7 +298,7 @@ writeComps <- function(inComps, inComps$f <- inComps$fsamps inComps$m <- inComps$msamps inComps$u <- inComps$usamps - } + } # We'll work key by key uKeys <- inComps$key[!duplicated(inComps$key)] @@ -299,53 +308,52 @@ writeComps <- function(inComps, if (verbose) { cat(length(uKeys), "unique keys for", nrow(inComps), "records\n\n") - #head(inComps) + # head(inComps) cat("\n\n") utils::flush.console() } # For each sex in turn - for ( g in c("m","f","u","b")) { + for (g in c("m", "f", "u", "b")) { myname <- g if (verbose) { cat(paste("Assembling, sex is:", myname, "\n")) utils::flush.console() } - tows <- which(names(inComps) == paste(g, "tows", sep = "")) + tows <- which(names(inComps) == paste(g, "tows", sep = "")) samps <- which(names(inComps) == paste(g, "samps", sep = "")) # Create output matrix output <- data.frame(matrix(nrow = length(uKeys), ncol = NCOLS, 0)) names(output) <- OutNames - for ( k in 1:length(uKeys) ) { + for (k in 1:length(uKeys)) { # Get the matching records slice <- inComps[inComps$key == uKeys[k], ] - if ( AAL ) { + if (AAL) { output$lbin[k] <- slice$lbin[1] } # End if - output$Nsamps[k] <- sum(slice[,samps], na.rm = TRUE) + output$Nsamps[k] <- sum(slice[, samps], na.rm = TRUE) # Use max here to take care of spurious NA problem that arises in getComps # for lengths where there are unsexed fish and no sexed fish. - output$Ntows[k] <- max(slice[,tows], na.rm = TRUE) + output$Ntows[k] <- max(slice[, tows], na.rm = TRUE) - for ( s in 1:length(slice[,target]) ) { - index <- slice[s, target] - output[k, index] <- slice[s, g] + output[k, index] + for (s in 1:length(slice[, target])) { + index <- slice[s, target] + output[k, index] <- slice[s, g] + output[k, index] } # End for s - } # End for k # Save and identify output[is.na(output)] <- 0 - if ( AAL ) { + if (AAL) { output$LbinLo <- LbinLo[output$lbin] # The low and high lbin on AAL typically are the same and match # the lower lbin - output$LbinHi <- LbinLo[output$lbin] #LbinHi[output$lbin] + output$LbinHi <- LbinLo[output$lbin] # LbinHi[output$lbin] } # End if # assign to a name like 'mComps' or 'fComps' @@ -360,33 +368,34 @@ writeComps <- function(inComps, # Creating a matrix of a specific size (mComps) # which is then being erased (blanks[,] <- 0) blanks <- mComps[1:NCOLS] - blanks[,] <- 0 + blanks[, ] <- 0 if (!"fishyr" %in% colnames(uStrat)) stop("fishyr should be a column") - if (!"fleet" %in% colnames(uStrat)) stop("fleet should be a column") - - if("season" %in% names(inComps)){ + if (!"fleet" %in% colnames(uStrat)) stop("fleet should be a column") + + if ("season" %in% names(inComps)) { use_month <- month[uStrat[, "season"]] } else { use_month <- month } - - uStrat <- data.frame(uStrat[, "fishyr"], - month = use_month, - uStrat[, 'fleet']) - colnames(uStrat) <- c("year", "month", "fleet") + + uStrat <- data.frame(uStrat[, "fishyr"], + month = use_month, + uStrat[, "fleet"] + ) + colnames(uStrat) <- c("year", "month", "fleet") # Fill the rest of the values uStrat$sex <- NA uStrat$partition <- partition - if ( length(AGE) > 0 ) { + if (length(AGE) > 0) { uStrat$ageErr <- ageErr uStrat$LbinLo <- -1 uStrat$LbinHi <- -1 } - if ( AAL ) { + if (AAL) { # Note that until empty rows are removed, the LbinLo and LbinHi columns # are the same in each dataset uStrat$ageErr <- ageErr @@ -394,80 +403,94 @@ writeComps <- function(inComps, uStrat$LbinHi <- fComps$LbinHi } - Ninput_b <- round(ifelse( - bComps$Nsamps / bComps$Ntows < 44, - bComps$Ntows + 0.138 * bComps$Nsamps, - 7.06 * bComps$Ntows), 0 ) + Ninput_b <- round(ifelse( + bComps$Nsamps / bComps$Ntows < 44, + bComps$Ntows + 0.138 * bComps$Nsamps, + 7.06 * bComps$Ntows + ), 0) Ninput_b[is.na(Ninput_b)] <- 0 - Ninput_f <- round(ifelse( - fComps$Nsamps / fComps$Ntows < 44, - fComps$Ntows + 0.138 * fComps$Nsamps, - 7.06 * fComps$Ntows), 0 ) + Ninput_f <- round(ifelse( + fComps$Nsamps / fComps$Ntows < 44, + fComps$Ntows + 0.138 * fComps$Nsamps, + 7.06 * fComps$Ntows + ), 0) Ninput_f[is.na(Ninput_f)] <- 0 - Ninput_m <- round(ifelse( - mComps$Nsamps / mComps$Ntows < 44, - mComps$Ntows + 0.138 * mComps$Nsamps, - 7.06 * mComps$Ntows), 0 ) - Ninput_m[is.na(Ninput_m)] = 0 - Ninput_u <- round(ifelse( - uComps$Nsamps / uComps$Ntows < 44, - uComps$Ntows + 0.138 * uComps$Nsamps, - 7.06 * uComps$Ntows), 0 ) + Ninput_m <- round(ifelse( + mComps$Nsamps / mComps$Ntows < 44, + mComps$Ntows + 0.138 * mComps$Nsamps, + 7.06 * mComps$Ntows + ), 0) + Ninput_m[is.na(Ninput_m)] <- 0 + Ninput_u <- round(ifelse( + uComps$Nsamps / uComps$Ntows < 44, + uComps$Ntows + 0.138 * uComps$Nsamps, + 7.06 * uComps$Ntows + ), 0) Ninput_u[is.na(Ninput_u)] <- 0 - if(!AAL){ - if(is.null(lbins_in)) { + if (!AAL) { + if (is.null(lbins_in)) { bins <- abins_in } else { bins <- lbins_in } - FthenM <- cbind(uStrat, round(bComps$Ntows, 0), round(bComps$Nsamps, 0), Ninput_b, - fComps[,1:NCOLS], mComps[,1:NCOLS]) + FthenM <- cbind( + uStrat, round(bComps$Ntows, 0), round(bComps$Nsamps, 0), Ninput_b, + fComps[, 1:NCOLS], mComps[, 1:NCOLS] + ) index <- grep("Ninput", names(FthenM)) - names(FthenM)[(index + 1):ncol(FthenM)] <- c(paste0('F', bins), paste0("M", bins)) - - Fout <- cbind(uStrat, round(fComps$Ntows, 0), round(fComps$Nsamps, 0), Ninput_f, - fComps[,1:NCOLS], fComps[,1:NCOLS]) + names(FthenM)[(index + 1):ncol(FthenM)] <- c(paste0("F", bins), paste0("M", bins)) + + Fout <- cbind( + uStrat, round(fComps$Ntows, 0), round(fComps$Nsamps, 0), Ninput_f, + fComps[, 1:NCOLS], fComps[, 1:NCOLS] + ) index <- grep("Ninput", names(Fout)) - colnames(Fout)[(index + 1):ncol(Fout)] <- c(paste0('F', bins), paste0("F.", bins)) - - Mout <- cbind(uStrat, round(mComps$Ntows, 0), round(mComps$Nsamps, 0), Ninput_m, - mComps[,1:NCOLS], mComps[,1:NCOLS]) + colnames(Fout)[(index + 1):ncol(Fout)] <- c(paste0("F", bins), paste0("F.", bins)) + + Mout <- cbind( + uStrat, round(mComps$Ntows, 0), round(mComps$Nsamps, 0), Ninput_m, + mComps[, 1:NCOLS], mComps[, 1:NCOLS] + ) index <- grep("Ninput", names(Mout)) - colnames(Mout)[(index + 1):ncol(Mout)] <- c(paste0('M', bins), paste0("M.", bins)) - - Uout <- cbind(uStrat, round(uComps$Ntows, 0), round(uComps$Nsamps, 0), Ninput_u, - uComps[,1:NCOLS], uComps[,1:NCOLS]) + colnames(Mout)[(index + 1):ncol(Mout)] <- c(paste0("M", bins), paste0("M.", bins)) + + Uout <- cbind( + uStrat, round(uComps$Ntows, 0), round(uComps$Nsamps, 0), Ninput_u, + uComps[, 1:NCOLS], uComps[, 1:NCOLS] + ) index <- grep("Ninput", names(Uout)) - colnames(Uout)[(index + 1):ncol(Uout)] <- c(paste0('U', bins), paste0("U.", bins)) + colnames(Uout)[(index + 1):ncol(Uout)] <- c(paste0("U", bins), paste0("U.", bins)) } else { # AAL - Fout <- cbind(uStrat, fComps$Nsamps, fComps[,1:NCOLS], fComps[,1:NCOLS]) - Mout <- cbind(uStrat, mComps$Nsamps, mComps[,1:NCOLS], mComps[,1:NCOLS]) - Uout <- cbind(uStrat, uComps$Nsamps, uComps[,1:NCOLS], uComps[,1:NCOLS]) + Fout <- cbind(uStrat, fComps$Nsamps, fComps[, 1:NCOLS], fComps[, 1:NCOLS]) + Mout <- cbind(uStrat, mComps$Nsamps, mComps[, 1:NCOLS], mComps[, 1:NCOLS]) + Uout <- cbind(uStrat, uComps$Nsamps, uComps[, 1:NCOLS], uComps[, 1:NCOLS]) FthenM <- NULL } # Make it pretty - if(!AAL) { + if (!AAL) { index <- grep("Ntows", names(Fout)) - names(Mout)[index] <- "Ntows" - names(Fout)[index] <- "Ntows" - names(Uout)[index] <- "Ntows" - names(FthenM)[index] <- "Ntows" + names(Mout)[index] <- "Ntows" + names(Fout)[index] <- "Ntows" + names(Uout)[index] <- "Ntows" + names(FthenM)[index] <- "Ntows" } index <- grep("Nsamp", names(Fout)) - names(Mout)[index] <- "Nsamps" - names(Fout)[index] <- "Nsamps" - names(Uout)[index] <- "Nsamps" - if(!AAL) { names(FthenM)[index] <- "Nsamps" } + names(Mout)[index] <- "Nsamps" + names(Fout)[index] <- "Nsamps" + names(Uout)[index] <- "Nsamps" + if (!AAL) { + names(FthenM)[index] <- "Nsamps" + } - if(!AAL){ + if (!AAL) { index <- grep("Ninput", names(Fout)) - names(Mout)[index] <- "InputN" - names(Fout)[index] <- "InputN" - names(Uout)[index] <- "InputN" + names(Mout)[index] <- "InputN" + names(Fout)[index] <- "InputN" + names(Uout)[index] <- "InputN" names(FthenM)[index] <- "InputN" } @@ -477,17 +500,27 @@ writeComps <- function(inComps, Mout <- Mout[Mout$Nsamps > 0, ] Uout <- Uout[Uout$Nsamps > 0, ] - if(dim(Uout)[1] != 0) { Uout$sex <- 0} - if(dim(Fout)[1] != 0) { Fout$sex <- 1} - if(dim(Mout)[1] != 0) { Mout$sex <- 2} - if(!AAL) { if(dim(FthenM)[1] != 0) { FthenM$sex <- 3 } } + if (dim(Uout)[1] != 0) { + Uout$sex <- 0 + } + if (dim(Fout)[1] != 0) { + Fout$sex <- 1 + } + if (dim(Mout)[1] != 0) { + Mout$sex <- 2 + } + if (!AAL) { + if (dim(FthenM)[1] != 0) { + FthenM$sex <- 3 + } + } # function to rescale comps to sum to 1 # IGT(2019-04-25): I tried using an apply function but kept messing up, # so fell back on a simple loop over the rows - rescale.comps <- function(out){ + rescale.comps <- function(out) { value.names <- grep("^[alfmuALFMU][0-9]+", colnames(out), value = TRUE) - for(irow in 1:nrow(out)){ + for (irow in 1:nrow(out)) { out[irow, names(out) %in% value.names] <- out[irow, names(out) %in% value.names] / sum(out[irow, names(out) %in% value.names]) @@ -495,8 +528,8 @@ writeComps <- function(inComps, # Code to apply the rescaled comps to the matrices # for Mout, Fout, or Uout composition data. The adj # value is based on the number of informational columns - # prior (year, fleet, partition) to the composition data. - if ("ageErr" %in% colnames(out)){ + # prior (year, fleet, partition) to the composition data. + if ("ageErr" %in% colnames(out)) { adj <- 11 } else { adj <- 8 @@ -504,35 +537,35 @@ writeComps <- function(inComps, # Only enter this if statement for the Mout, Fout, or # Uout composition data. This allows the rounding to be # applied to that second copy print of the composition data. - if (length(value.names) < (dim(out)[2] - adj)){ + if (length(value.names) < (dim(out)[2] - adj)) { find <- which(names(out) == value.names[1]) - ind <- (find + length(value.names)):dim(out)[2] + ind <- (find + length(value.names)):dim(out)[2] out[, ind] <- out[, names(out) %in% value.names] } return(out) } # function to round comps - round.comps <- function(out, digits){ + round.comps <- function(out, digits) { value.names <- grep("^[alfmuALFMU][0-9]+", colnames(out), value = TRUE) out[, names(out) %in% value.names] <- round(out[, names(out) %in% value.names], digits = digits) - if ("ageErr" %in% colnames(out)){ + if ("ageErr" %in% colnames(out)) { adj <- 11 } else { adj <- 8 } - if (length(value.names) < (dim(out)[2] - adj)){ + if (length(value.names) < (dim(out)[2] - adj)) { find <- which(names(out) == value.names[1]) ind <- (length(value.names) + find):dim(out)[2] - out[, ind] <- + out[, ind] <- round(out[, names(out) %in% value.names], digits = digits) } return(out) } - + # optionally rescale to sum to 1 # this needs to happen after combining FthenM rather than to # the sex-specific parts @@ -540,19 +573,25 @@ writeComps <- function(inComps, if (verbose) { message("rescaling comps to sum to 1") } - if (dim(Uout)[1] != 0) { Uout <- rescale.comps(Uout) } - if (dim(Fout)[1] != 0) { Fout <- rescale.comps(Fout) } - if (dim(Mout)[1] != 0) { Mout <- rescale.comps(Mout) } - if (!AAL) { - if (dim(FthenM)[1] != 0) { - FthenM <- rescale.comps(FthenM) - } + if (dim(Uout)[1] != 0) { + Uout <- rescale.comps(Uout) + } + if (dim(Fout)[1] != 0) { + Fout <- rescale.comps(Fout) + } + if (dim(Mout)[1] != 0) { + Mout <- rescale.comps(Mout) + } + if (!AAL) { + if (dim(FthenM)[1] != 0) { + FthenM <- rescale.comps(FthenM) + } } } # optionally round off to chosen value if (!missing(digits)) { - if (verbose){ + if (verbose) { message("rounding values to ", digits, " digits") } if (dim(Uout)[1] != 0) { @@ -573,56 +612,68 @@ writeComps <- function(inComps, # Print the whole shebang out to a file. ## # Turn off warnings about "appending column names to file" - oldwarn = options("warn") + oldwarn <- options("warn") options("warn" = -1) if (verbose) { cat("Writing FthenM, dimensions:", dim(FthenM), "\n") } - IDstring = paste("\n\n", "Females then males") - cat(file = fname, IDstring, "\n", append = FALSE) - utils::write.table(file = fname, FthenM, sep = ",", col.names = TRUE, - row.names = FALSE, append = TRUE) + IDstring <- paste("\n\n", "Females then males") + cat(file = fname, IDstring, "\n", append = FALSE) + utils::write.table( + file = fname, FthenM, sep = ",", col.names = TRUE, + row.names = FALSE, append = TRUE + ) if (verbose) { cat("Writing F only, dimensions:", dim(Fout), "\n") } - IDstring = paste("\n\n", "Females only") - cat(file = fname, IDstring, "\n", append = TRUE) - utils::write.table(file = fname, Fout, sep = ",", col.names = TRUE, - row.names = FALSE, append = TRUE) - + IDstring <- paste("\n\n", "Females only") + cat(file = fname, IDstring, "\n", append = TRUE) + utils::write.table( + file = fname, Fout, sep = ",", col.names = TRUE, + row.names = FALSE, append = TRUE + ) + if (verbose) { cat("Writing M only, dimensions:", dim(Mout), "\n") - } - IDstring = paste("\n\n", "Males only") + } + IDstring <- paste("\n\n", "Males only") cat(file = fname, IDstring, "\n", append = TRUE) - utils::write.table(file = fname, Mout, sep =",", col.names = TRUE, - row.names = FALSE, append = TRUE) + utils::write.table( + file = fname, Mout, sep = ",", col.names = TRUE, + row.names = FALSE, append = TRUE + ) if (verbose) { cat("Writing U only, dimensions:", dim(Uout), " \n") - } + } - if("sexRatio" %in% colnames(inComps)){ - u_message <- paste("\n\n", - "Sex ratio was applied and unsexed are included above: only reported as a diagnostic") + if ("sexRatio" %in% colnames(inComps)) { + u_message <- paste( + "\n\n", + "Sex ratio was applied and unsexed are included above: only reported as a diagnostic" + ) } else { u_message <- paste("\n\n", "Usexed only") } - IDstring = u_message + IDstring <- u_message cat(file = fname, IDstring, "\n", append = TRUE) - utils::write.table(file = fname, Uout, sep = ",", col.names = TRUE, - row.names = FALSE, append = TRUE) - + utils::write.table( + file = fname, Uout, sep = ",", col.names = TRUE, + row.names = FALSE, append = TRUE + ) + # Reset warnings - #options("warn" = oldwarn[[1]]) - #invisible(eval(parse(text = returns))) + # options("warn" = oldwarn[[1]]) + # invisible(eval(parse(text = returns))) # return tables - invisible(list(FthenM = FthenM, - Fout = Fout, - Mout = Mout, - Uout = Uout)) + invisible(list( + FthenM = FthenM, + Fout = Fout, + Mout = Mout, + Uout = Uout + )) } # End function writeComps diff --git a/man/PacFIN.Utilities.Rd b/man/PacFIN.Utilities.Rd index fc6f389..8bab931 100644 --- a/man/PacFIN.Utilities.Rd +++ b/man/PacFIN.Utilities.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/PacFIN.Utilities.R \docType{package} \name{PacFIN.Utilities} +\alias{PacFIN.Utilities-package} \alias{PacFIN.Utilities} \title{PacFIN.Utilities: Functions for working up PacFIN data} \description{ @@ -89,3 +90,21 @@ You can run these manually to reset the initial values. \link{capValues} Used to limit the maximum value in a vector. } +\author{ +\strong{Maintainer}: Kelli F. Johnson \email{kelli.johnson@noaa.gov} (\href{https://orcid.org/0000-0002-5149-451X}{ORCID}) + +Authors: +\itemize{ + \item Chantel R. Wetzel \email{chantel.wetzel@noaa.gov} (\href{https://orcid.org/0000-0002-7573-8240}{ORCID}) +} + +Other contributors: +\itemize{ + \item Kathryn L. Doering \email{kathryn.doering@noaa.gov} (\href{https://orcid.org/0000-0002-0396-7044}{ORCID}) [contributor] + \item Brian J. Langseth \email{brian.langseth@noaa.gov} (\href{https://orcid.org/0000-0002-9901-6146}{ORCID}) [contributor] + \item Andi Stephens \email{andi.stephens@noaa.gov} [contributor] + \item Ian G. Taylor \email{ian.taylor@noaa.gov} (\href{https://orcid.org/0000-0002-4232-5669}{ORCID}) [contributor] + \item John R. Wallace \email{john.wallace@noaa.gov} (\href{https://orcid.org/0000-0002-2333-1262}{ORCID}) [contributor] +} + +} diff --git a/man/comps_bins.Rd b/man/comps_bins.Rd index 4bfcc8e..9403737 100644 --- a/man/comps_bins.Rd +++ b/man/comps_bins.Rd @@ -39,8 +39,8 @@ centimeter is not its own bin. comps_bins(1:8, breaks = c(-Inf, 3:5)) comps_bins(1:8, breaks = c(3:5), includeplusgroup = FALSE) testthat::expect_equal( -comps_bins(1:8, breaks = c(-Inf, 3:5, Inf)), -comps_bins(1:8, breaks = c(-Inf, 3:5), includeplusgroup = TRUE) + comps_bins(1:8, breaks = c(-Inf, 3:5, Inf)), + comps_bins(1:8, breaks = c(-Inf, 3:5), includeplusgroup = TRUE) ) } diff --git a/man/comps_wide.Rd b/man/comps_wide.Rd index 55c89a7..ace1441 100644 --- a/man/comps_wide.Rd +++ b/man/comps_wide.Rd @@ -53,7 +53,8 @@ temp <- data.frame( state = rep(c("WA", "OR"), length.out = 30), year = rep(2010:2015, each = 5), Age = rep(1:15, 2), - ap = rlnorm(n = 30)) + ap = rlnorm(n = 30) +) comps <- comps_wide(temp, breaks = 3:8, col_proportions = "ap") testthat::expect_equal(NCOL(comps), 8) \dontrun{ diff --git a/man/getSeason.Rd b/man/getSeason.Rd index d42bb40..e9a297e 100644 --- a/man/getSeason.Rd +++ b/man/getSeason.Rd @@ -61,7 +61,8 @@ in \link{cleanPacFIN}. If a specialized season structure is required, \examples{ test <- getSeason( data.frame(SAMPLE_MONTH = 1:12, fishyr = rep(1:2, each = 6)), - verbose = TRUE) + verbose = TRUE +) testthat::expect_true(all(test[, "season"] == 1)) test <- getSeason(Pdata = test, season_type = 1, yearUp = 12) testthat::expect_equivalent(test[test[, "fishyr"] == 3, "season"], 1) diff --git a/man/getState.Rd b/man/getState.Rd index c7f8973..1580db5 100644 --- a/man/getState.Rd +++ b/man/getState.Rd @@ -70,9 +70,10 @@ please contact the package maintainer. \examples{ data <- data.frame( AGENCY_CODE = rep(c("W", "O", "C"), each = 2), - info = 1:6) + info = 1:6 +) testthat::expect_true( -all(getState(data)[["state"]] == rep(c("WA", "OR", "CA"), each = 2)) + all(getState(data)[["state"]] == rep(c("WA", "OR", "CA"), each = 2)) ) }