Skip to content

Commit

Permalink
Merge pull request #78 from NOAA-EDAB/andy_aggtest
Browse files Browse the repository at this point in the history
aggregate_area function rework
  • Loading branch information
sgaichas authored Oct 3, 2024
2 parents 7890eec + b868a1e commit 7e15429
Show file tree
Hide file tree
Showing 5 changed files with 189 additions and 35 deletions.
22 changes: 7 additions & 15 deletions R/aggregate_area.R
Original file line number Diff line number Diff line change
Expand Up @@ -4,27 +4,17 @@
#' statistical areas to a user defined area. Allows for species to be assigned by
#' proportions to more than two user defined areas from one stat area
#'
#'@inheritParams get_comland_data
#'@param comland Data set generated by \code{get_comland_data}
#'@param userAreas Data frame. Definitions to aggregate statistical areas to user defined areas
#'@param areaDescription Character. Name of column in userAreas that defines the new area.
#'@param propDescription Character. Name of column in userAreas that defines the
#'proportions of landings assigned to new area.
#'
#'@noRd

aggregate_area <- function(comData, userAreas, areaDescription, propDescription,
useForeign, channel, applyPropLand = T,
applyPropValue = T){
useForeign, channel, applyProp){

#Pulling data
message("Aggregating Areas ...")

#Add message
if(applyPropLand == F & applyPropValue == T){
message("Can not apply proportions to Value and not Landings -- setting applyPropLand to F")
applyPropLand <- F
}

#Grab just the data
comdata <- comData[[1]]

Expand Down Expand Up @@ -81,8 +71,9 @@ aggregate_area <- function(comData, userAreas, areaDescription, propDescription,
areas <- data.table::rbindlist(list(areas, div.prop), use.names = T)
}

#Apply proportions to Landings
#Merge new area descriptions to landings
if(applyPropLand){
if(applyProp){
new.area <- merge(comdata, areas, by = c('NESPP3', 'AREA'), all.x = T,
allow.cartesian = T)
} else {
Expand All @@ -98,10 +89,11 @@ aggregate_area <- function(comData, userAreas, areaDescription, propDescription,

#Proportion landings to new areas
new.area[, newspplivmt := SPPLIVMT * prop]
if(applyPropValue) new.area[, newsppvalue := SPPVALUE * prop]

# Apply proportions to Value
#Drop extra columns and rename
if(applyPropValue){
if(applyProp){
new.area[, newsppvalue := SPPVALUE * prop]
new.area[, c('AREA', 'SPPLIVMT', 'SPPVALUE', 'prop') := NULL]
data.table::setnames(new.area, c('newarea', 'newspplivmt', 'newsppvalue'),
c(areaDescription, 'SPPLIVMT', 'SPPVALUE'))
Expand Down
107 changes: 107 additions & 0 deletions R/check_argument_validation.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,107 @@
#' Argument Flag check
#'
#' check to make sure arguments passed bby user do not contradict each other.
#'
#' @inheritParams get_comland_data
#'
#' @noRd

# We can either create error messages (like below) or fix argument specs

check_argument_validation <- function(aggArea,
userAreas,
areaDescription,
propDescription,
applyProp,
aggGear,
userGears,
fleetDescription,
unkVar,
knStrata) {

############## AggArea ###############

# if aggArea = T then userAreas, areaDescription and propDescription
# follow rules
if(aggArea) {
# field names of userAreas
if(!(areaDescription %in% names(userAreas))) {
stop(paste0(areaDescription, " is not a field name in userAreas object"))
}
if(!(propDescription %in% names(userAreas))) {
stop(paste0(propDescription, " is not a field name in userAreas object"))
}
if(!("AREA" %in% names(userAreas))) {
stop(paste0("AREA is not a field name in userAreas object.
This object is used to aggregate Statistical Areas to larger regional units.
Field names must include: AREA and 'areaDescription' "))
}
}

############## AggGear ###############

# if aggGear = T then userGears, fleetDescription follow rules
if(aggGear) {
# field names of userGears
if(!(fleetDescription %in% names(userGears))) {
stop(paste0(fleetDescription, " is not a field name in userGears object"))
}
}

############## applyProp ###############

# applyProp currently relies on a specific format of userAreas
if(applyProp) {
if (!aggArea) {
stop("Can not have 'aggArea = F' if you want to propotion landings ('applyProp = T') by
statistical area to a larger spatial unit")
}

# if aggArea = T hen these conditions should be met
if(!("NESPP3" %in% names(userAreas))) {
stop(paste0("NESPP3 is not a field name in userAreas object.
This object is used to aggregate Statistical Areas to larger regional units and
proportion landings to these larger regional unit depening on the species and Statistical area.
Field names must include: NESPP3, AREA and 'areaDescription' "))
}

stop("Proportion allocation is currently not implemented correctly.
Please use 'applyProp = F'")

}

################ UNKNOWNS #################

# checks for filling in missing values (assign_unknowns)
# Depending on the flags above will determine how the arguments unkVar and knStrata are defined
if (aggArea) {
if (!(areaDescription %in% unkVar) | !(areaDescription %in% knStrata)) {
stop(paste0("To assign unknowns when using 'aggArea = T', then you need to replace
'AREA' with '" ,areaDescription,"' in both 'unkVar' and 'knStrata' arguments"))
}
} else {
if (!("AREA" %in% unkVar) | !("AREA" %in% knStrata)) {
stop(paste0("To assign unknowns when using 'aggArea = F', then you need to use
'AREA' in both 'unkVar' and 'knStrata' arguments"))
}

}

if (aggGear) {
if (!(fleetDescription %in% unkVar) | !(fleetDescription %in% knStrata)) {
stop(paste0("To assign unknowns when using 'aggGear = T', then you need to replace
'NEGEAR' with '" ,fleetDescription,"' in both 'unkVar' and 'knStrata' arguments"))
}
} else {
if (!("NEGEAR" %in% unkVar) | !("NEGEAR" %in% knStrata)) {
stop(paste0("To assign unknowns when using 'aggGear = F', then you need to use
'NEGEAR' in both 'unkVar' and 'knStrata' arguments"))
}
}




# check for character or numeric

}
65 changes: 52 additions & 13 deletions R/get_comland_data.R
Original file line number Diff line number Diff line change
Expand Up @@ -22,8 +22,7 @@
#'@param userAreas data frame. Spatial units in which Statistical areas should be aggregated (eg. \code{\link{mskeyAreas}})
#'@param areaDescription character string. Field name in \code{userAreas} denoting spatial unit. (Default = "EPU")
#'@param propDescription character string. Field name in \code{userAreas} denoting the scaling factor. (Default = "MeanProp")
#'@param applyPropLand boolean. Apply the proportions in userAreas to the landings (Default = F)
#'@param applyPropValue boolean. Apply the proportions in userAreas to the value (Default = F)
#'@param applyProp boolean. Apply the proportions in userAreas to the landings and value (Default = T)
#'@param aggGear boolean. Aggregate NEGEAR codes to larger "fleets" (Default = F)
#'@param userGears data frame. Fleet designations in which NEGEAR codes should be grouped (eg. \code{\link{mskeyGears}})
#'@param fleetDescription character string. Field name in \code{userGears} denoting Fleet. (Default = "Fleet")
Expand All @@ -49,17 +48,42 @@
#'@importFrom data.table ":="
#'@importFrom magrittr "%>%"
#'
#'@section Argument choices:
#'
#'Some of the arguments rely on the choice of others.
#'
#'If \code{aggArea = T} then the user must also supply a \code{userAreas} data frame
#' and a \code{areaDescription} string to denote the field in \code{userArea} which
#' maps the statistical area to the larger spatial unit.
#'
#'If \code{aggGear = T} then the user must also supply a \code{userGears} data frame
#' and a \code{fleetDescription} string to denote the field in \code{userGears} which
#' maps the NEGEAR codes to the fleet designation.
#'
#' If either \code{aggArea = T} or \code{aggGear = T} and the user wants to assign values to
#' missing variables (i.e. if \code{unkVar} != NULL) then \code{unkVar} and \code{knStrata} need to
#' include the values of \code{areaDescription} and \code{fleetDescription} respectively
#'
#'@export


get_comland_data <- function(channel, filterByYear = NA,
filterByArea = NA, useLanded = T, removeParts = T,
useHerringMaine = T, useForeign = T, refYear = NA,
refMonth = NA, disagSkatesHakes = T, aggArea = F,
get_comland_data <- function(channel,
filterByYear = NA,
filterByArea = NA,
useLanded = T,
removeParts = T,
useHerringMaine = T,
useForeign = T,
refYear = NA,
refMonth = NA,
disagSkatesHakes = T,
aggArea = F,
userAreas = comlandr::mskeyAreas,
areaDescription = 'EPU', propDescription = 'MeanProp',
applyPropLand = T, applyPropValue = T,
aggGear = F, userGears = comlandr::mskeyGears,
areaDescription = 'EPU',
propDescription = 'MeanProp',
applyProp = F,
aggGear = F,
userGears = comlandr::mskeyGears,
fleetDescription = 'Fleet',
unkVar = c('MONTH','NEGEAR','AREA'),
knStrata = c('HY', 'QY','MONTH','NEGEAR', 'TONCL2', 'AREA')) {
Expand All @@ -68,6 +92,20 @@ get_comland_data <- function(channel, filterByYear = NA,

call <- dbutils::capture_function_call()


check_argument_validation(aggArea,
userAreas,
areaDescription,
propDescription,
applyProp,
aggGear,
userGears,
fleetDescription,
unkVar,
knStrata
)


#Pull raw data
comland <- comlandr::get_comland_raw_data(channel,
filterByYear, filterByArea,
Expand Down Expand Up @@ -109,8 +147,9 @@ get_comland_data <- function(channel, filterByYear = NA,

#Disaggregate skates and hakes
if(disagSkatesHakes) comland <- disaggregate_skates_hakes(comland,
channel,
filterByYear, filterByArea)
channel,
filterByYear,
filterByArea)

#Aggregate areas
if(aggArea) comland <- aggregate_area(comland,
Expand All @@ -119,8 +158,8 @@ get_comland_data <- function(channel, filterByYear = NA,
propDescription,
useForeign,
channel,
applyPropLand,
applyPropValue)
applyProp)

#Aggregate gears
if(aggGear) comland <- aggregate_gear(comland, userGears, fleetDescription)

Expand Down
5 changes: 3 additions & 2 deletions R/get_comland_raw_data.R
Original file line number Diff line number Diff line change
Expand Up @@ -24,8 +24,9 @@
get_comland_raw_data <- function(channel, filterByYear = NA, filterByArea = NA,
useLanded = T, removeParts = T){

#If not specifying a year default to 1964 - 2019
if(is.na(filterByYear[1])) filterByYear <- 1964:2019
#If not specifying a year default to 1964 - current year
currentYear <- as.numeric(format(Sys.Date(),"%Y"))
if(is.na(filterByYear[1])) filterByYear <- 1964:currentYear
filteryears <- sqltext(filterByYear)

message(paste0("Pulling landings data from ",
Expand Down
25 changes: 20 additions & 5 deletions man/get_comland_data.Rd

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit 7e15429

Please sign in to comment.