Merge pull request #19 from NOAA-EDAB/SeanOverhaul

Sean overhaul

NAMESPACE

@@ -1,6 +1,15 @@
 # Generated by roxygen2: do not edit by hand
 
+export(aggregate_area)
+export(aggregate_gear)
+export(assign_area)
+export(calc_DK)
 export(comland)
+export(disaggregate_skates_hakes)
+export(get_comdisc_raw_data)
+export(get_comland_data)
+export(get_comland_raw_data)
+export(get_herring_data)
 export(get_areas)
 export(get_comland_data)
 export(get_foreign_data)

R/adjust_inflation.R

@@ -6,8 +6,8 @@
 #'
 #'
 #'@param comland Data frame. master data frame containing species landings
-#'@param refmonth Integer. Reference month
-#'@param refyear Integer. Reference year
+#'@param refMonth Integer. Reference month
+#'@param refYear Integer. Reference year
 #'
 #'@return comland data frame adjusted for inflation
 #'
@@ -16,7 +16,17 @@
 
 
 
-adjust_inflation <- function(comland,refyear,refmonth){
+adjust_inflation <- function(comland, refYear, refMonth){
+
+  call <- c(comland$call, capture_function_call())
+
+  #Pulling data
+  message("Adjusting for inflation ...")
+
+  #pull out comland data
+  sql <- comland$sql
+  comland <- comland$comland
+
   temp <- tempfile()
   download.file("http://download.bls.gov/pub/time.series/wp/wp.data.3.ProcessedFoods", temp)
   inflate <- data.table::as.data.table(read.delim(temp))
@@ -37,5 +47,9 @@ adjust_inflation <- function(comland,refyear,refmonth){
 
   #Remove extra column
   comland[, PPI := NULL]
-  return(comland)
+
+  return(list(comland      = comland[], 
+              sql          = sql,
+              pullDate     = date(),
+              functionCall = call))
 }

R/aggregate_area.R

@@ -0,0 +1,60 @@
+#' Assign landing records to an aggregated area
+#'
+#' Takes the output from \code{get_comland_data} and further aggregates from NAFO 
+#' 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
+#'
+#'@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.
+#'
+#'@export
+
+aggregate_area <- function(comland, userAreas, areaDescription, propDescription,
+                           applyPropValue = T){
+
+  #Pulling data
+  message("Aggregating Areas ...")
+
+  #Grab just the data
+  comData <- comland$comland
+
+  call <- dbutils::capture_function_call()
+
+  #Convert userAreas to data.table
+  areas <- data.table::as.data.table(userAreas)
+  data.table::setnames(areas, c(areaDescription, propDescription), c('newarea', 'prop'))
+
+  #Merge new area descriptions to landings
+  new.area <- merge(comData, areas, by = c('NESPP3', 'AREA'), all.x = T, allow.cartesian=TRUE)
+
+  #If no proportion assume 100% in
+  new.area[is.na(prop), prop := 1]
+
+  #Proportion landings to new areas
+  new.area[, newspplivmt := SPPLIVMT * prop]
+  if(applyPropValue) new.area[, newsppvalue := SPPVALUE * prop]
+
+  #Drop extra columns and rename
+  if(applyPropValue){
+    new.area[, c('SPPLIVMT', 'SPPVALUE', 'prop') := NULL]
+    data.table::setnames(new.area, c('newarea', 'newspplivmt', 'newsppvalue'), 
+                         c(areaDescription, 'SPPLIVMT', 'SPPVALUE'))
+  } else {
+    new.area[, c('SPPLIVMT', 'prop') := NULL]
+    data.table::setnames(new.area, c('newarea', 'newspplivmt'), 
+                         c(areaDescription, 'SPPLIVMT'))
+  }
+
+
+  #Add changes back into comland
+   comland$comland <- new.area[]
+   comland$call <- c(comland$call, call)
+   comland$userAreas <- userAreas
+
+  return(comland[])
+}                 

R/aggregate_gear.R

@@ -0,0 +1,54 @@
+#' Assign landing records to an aggregated area
+#'
+#' Takes the output from \code{get_comland_data} and further aggregates from NAFO 
+#' 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
+#'
+#'@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.
+#'
+#'@export
+
+aggregate_gear <- function(comData, userGears, fleetDescription){
+
+  call <- dbutils::capture_function_call()
+
+  #Convert userGears to data.table
+  gears <- data.table::as.data.table(userGears)
+  gears <- data.table::setnames(gears, fleetDescription, 'fleet')
+
+  #Assign gears to fleets
+  #Generate NEGEAR2 codes from NEGEAR
+  if(is.numeric(comData$NEGEAR)){
+    comData[NEGEAR < 100, NEGEAR3 := paste0(0, NEGEAR)]
+    comData[NEGEAR >= 100, NEGEAR3 := NEGEAR]
+    comData[, NEGEAR2 := as.numeric(substr(NEGEAR3, 1, 2))]
+  } else {
+    comData[, NEGEAR2 := as.numeric(substr(NEGEAR, 1, 2))]
+  }
+
+  fleets <- unique(gears$fleet)
+
+  for(ifleet in 1:length(fleets)){
+    fleet.gear <- gears[fleet == fleets[ifleet], NEGEAR2]
+    fleet.mesh <- unique(gears[fleet == fleets[ifleet], MESHCAT])
+    #Check if there is a mesh characteristic associated with this gear
+    if(is.na(fleet.mesh)){
+      comData[NEGEAR2 %in% fleet.gear, fleet := fleets[ifleet]]
+    } else {
+      comData[NEGEAR2 %in% fleet.gear & MESHCAT == fleet.mesh, fleet := fleets[ifleet]]
+    }
+  }
+
+  comData[, fleet := as.factor(fleet)]
+
+  #Rename columns
+  data.table::setnames(comData, 'fleet', fleetDescription)
+
+  return(comData[])
+}                 

R/assign_area.R

@@ -0,0 +1,70 @@
+#' Assigns points to polygon
+#'
+#' Assign observer data (points, lat and lon) to designated regions (polygons) from a shape file.
+#'
+#'
+# @inheritParams strat_prep
+#' @param na.keep Boolean. Logical value to indicate whether original strata names
+#'  should be retained.
+#'
+#' @return Returns a \code{comdiscData} data.table with one additional column labeled
+#'  with the value of \code{areaDescription}
+#'
+#' \item{areaDescription}{The name of the region (found in \code{areaPolygon})
+#'  that a record in \code{surveyData} is assigned to}
+#'
+#' @importFrom magrittr "%>%"
+#'
+#'@family comdisc
+#'
+#' @export
+
+
+assign_area <- function (comdiscData, areaPolygon, areaDescription, na.keep = F) {
+
+    # transform Regional Shape file using lambert conformal conic coordinate ref system
+    crs <- "+proj=lcc +lat_1=20 +lat_2=60 +lat_0=40 +lon_0=-72 +x_0=0 +y_0=0 +datum=NAD83 +units=m +no_defs +ellps=GRS80 +towgs84=0,0,0"
+
+    areas <- areaPolygon %>%
+    dplyr::rename(areaDescription = areaDescription) %>%
+    sf::st_transform(., crs)
+
+    #Need unique link3, lat lon column to make this work
+    comdiscData[, linkLL := paste0(LINK3, LAT, LON)]
+    #Should probably do this in the raw data pull
+    #remove stations missing lat or lon
+    comdiscData <- comdiscData[!is.na(LAT), ]
+    comdiscData <- comdiscData[!is.na(LON), ]
+
+    # find unique stations and transform to required crs
+    locations <- comdiscData %>%
+    dplyr::select(linkLL, LAT, LON) %>%
+    dplyr::distinct() %>%
+    sf::st_as_sf(., coords = c("LON","LAT"), crs=4326) %>%
+    sf::st_transform(., crs)
+
+
+    # Intersect the locations with the polygon
+    # Assigns locations with polygons
+    location_area <- sf::st_join(locations, areas, join = sf::st_intersects) %>%
+    dplyr::select(names(locations), areaDescription) %>%
+    sf::st_drop_geometry() %>%
+    dplyr::arrange(linkLL)
+
+    # Join observer data with locations (which now are assigned to an area based on the shape file)
+    master <- base::merge(comdiscData, location_area, by = c("linkLL")) %>%
+    dplyr::rename(!!areaDescription := areaDescription)
+
+    # check to see if we want to keep points that fall outside of all of the polygons found in the shape file
+    if (!(na.keep)) { # removes all points that fall outside of the areas defined by the polygons in stratum
+    master <- master %>%
+        dplyr::filter(!is.na(get(areaDescription))) %>%
+        data.table::as.data.table()
+  }
+    #Drop linkLL column
+    master[, linkLL := NULL]
+
+  return(master[])
+
+}
+

R/calc_DK.R

@@ -0,0 +1,62 @@
+#' Calculate discard to kept ratio
+#'
+#' Use observer data to calculate the ratio of discards to kept by species.
+#' 
+#'
+# @inheritParams strat_prep
+#' @param na.keep Boolean. Logical value to indicate whether original strata names
+#'  should be retained.
+#'
+#' @return Returns a \code{comdiscData} data.table with one additional column labeled
+#'  with the value of \code{areaDescription}
+#'
+#' \item{areaDescription}{The name of the region (found in \code{areaPolygon})
+#'  that a record in \code{surveyData} is assigned to}
+#'
+#' @importFrom magrittr "%>%"
+#'
+#'@family comdisc
+#'
+#' @export
+
+
+calc_DK <- function(comdiscData, areaDescription, fleetDescription){
+
+  #Standardize column names
+  comdiscData <- data.table::setnames(comdiscData, c(areaDescription, 
+                                                     fleetDescription), 
+                                      c('area', 'fleet'))
+
+  #sum catch by species/disposition/area/fleet
+  ob.sums <- comdiscData[, sum(SPPLIVMT), by = c('YEAR', 'area', 'fleet', 'NESPP3',
+                                                 'CATDISP')]
+  #identify discards
+  ob.discard <- ob.sums[CATDISP == 0, ]
+
+  setnames(ob.discard, "V1", "DISCARD")
+  ob.discard[, CATDISP := NULL]
+
+  #Sum kept by area/fleet
+  ob.kept <- ob.sums[CATDISP == 1, sum(V1), by = c('YEAR', 'area', 'fleet')]
+
+  setnames(ob.kept, "V1", "KEPT.ALL")
+
+  #Merge discards and kept
+  dk <- merge(ob.kept, ob.discard, by = c('YEAR', 'area', 'fleet'))
+
+  #Calculate ratio
+  dk[, DK := DISCARD / KEPT.ALL]
+  #NAs result if divide by 0 so set DK to 1 (all discards)
+  dk[is.na(DK), DK := 1.0]
+
+  #Remove extra columns
+  dk[, c('KEPT.ALL', 'DISCARD') := NULL]
+
+  #Replace standard column names
+  #Standardize column names
+  data.table::setnames(dk, c('area', 'fleet'), 
+                       c(areaDescription, fleetDescription))
+
+  return(dk[])
+}
+