R/flagTools.r

Defines functions flagSort flagExtract diffFlagsStepwise flagMeaning flagDiff diffFlags flagSummary recPeriod

Documented in diffFlags diffFlagsStepwise flagDiff flagMeaning flagSort flagSummary recPeriod

# FLR4MFCL - R4MFCL built with FLR classes
# Copyright (C) 2018  Rob Scott

#' Recruitment Periods
#'
#' Calculate recruitment periods for deterministic and stochastic projection
#' settings.
#'
#' @param par an object of class MFCLPar.
#' @param af199 undocumented.
#' @param af200 undocumented.
#' @param pf232 undocumented.
#' @param pf233 undocumented.
#' @param show undocumented.
#'
#' @return An object of class numeric vector.
#'
#' @examples
#' data(par)
#' recPeriod(par)
#'
#' @export

recPeriod <- function(par, af199=NULL, af200=NULL, pf232=NULL, pf233=NULL,
                      show=FALSE){

  mat_d <- matrix(rev(1:dimensions(par)["years"]),
                  ncol=dimensions(par)["seasons"], byrow=TRUE)
  rownames(mat_d) <- as.character(range(par)["minyear"]:range(par)["maxyear"])

  mat_s <- matrix(1:dimensions(par)["years"], ncol=dimensions(par)["seasons"],
                  byrow=TRUE)
  rownames(mat_s) <- as.character(range(par)["minyear"]:range(par)["maxyear"])

  if(show){
    print("Deterministic"); print(mat_d)
    print("Stochastic")   ; print(mat_s)
    print("Flags")
  }

  # If flag values given as args : calculate corresponding values
  if(!is.null(af199) && is.null(pf232))
    pf232 <- mat_s[mat_d==af199]           # bug fix af199 cannot be zero - need to change it to 1
  if(!is.null(af200) && is.null(pf233))
    pf233 <- mat_s[mat_d==af200]

  if(!is.null(pf232) && is.null(af199))
    af199 <- mat_s[mat_d==pf232]
  if(!is.null(pf233) && is.null(af200))
    af200 <- mat_s[mat_d==pf233]

  # If no flagvals given as args : use values given in the par
  if(is.null(af199))
    af199 <- flagval(par, 2, 199)$value
  if(is.null(af200))
    af200 <- flagval(par, 2, 200)$value
  if(is.null(pf232))
    pf232 <- flagval(par, 1, 232)$value
  if(is.null(pf233))
    pf233 <- flagval(par, 1, 233)$value

  res <- c(af199, af200, pf232, pf233)
  names(res) <- c('af199', 'af200', 'pf232', 'pf233')

  return(res)
}


#' Flag Summary
#'
#' Flag settings summarised by MFCL User Guide sections.
#'
#' @param par An object of class MFCLPar.
#' @param type A character string specifying the MFCL User Guide section.
#'
#' @return A data frame of flag settings.
#'
#' @examples
#' data(par)
#' flagSummary(par, 'projection')
#'
#' @export

flagSummary <- function(par, type){

  options <- c('projection', 'impact_analysis', 'MSY', 'CC', 'catch_err', 'fml_effort_rel', 'catchability', 
               'selectivity', 'tag', 'movement')

  if(!is.element(type, options))
    stop(paste("arg 'type' must be one of the following:", paste0(options, collapse="; ")))
  
  ffrange <- 1:dimensions(par)['fisheries']
  #ttrange <- 1:dimensions(par)['taggrps']  # dimensions(taggrps) not currently working - 16/08/23
  ttrange <- (unique(subset(flags(par), flagtype%in%-9999:-99999)$flagtype)*-1)-10000
  
  catchability_fshflags   <- sort(c(1,10,15,23,27,47,28,29))
  selectivity_fshflags    <- sort(c(48,3,16,19,20,21,24,26,56,57,61,71,74,72,75))
  fml_effort_rel_fshflags <- sort(c(27,29,73,81,93))
  tag_fshflags            <- sort(c(32, 33, 34, 35, 36, 37, 43, 44, 45, 46))
  
  #browser()
  switch(
    type,
    projection=rbind(flagval(par, 1, c(142, 231:239)),
                     flagval(par, 2, c(20, 190, 191, 195, 161, 199, 200))),
    impact_analysis=rbind(flagval(par, 2, c(170:176, 190, 191, 193)),
                          flagval(par, ffrange, 55)),
    MSY=rbind(
      flagval(par, 2, c(112, 140:141, 145:155, 161:163, 165:169, 194, 199:200)),
      flagval(par, ffrange, 70)),
    CC=rbind(
      flagval(par, 1, c(373, 382)),
      flagval(par, 2, c(92, 116, 189))),
    catch_err=list(
      flagval(par, 2, c(34, 35, 144)),
      matrix(flagval(par, -(ffrange), c(1, 4, 10, 13, 15, 23, 45, 47))$value, 
             nrow=length(ffrange), byrow=T, 
             dimnames=list(paste('fsh', ffrange),paste('flag', c(1, 4, 10, 13, 15, 23, 45, 47))))),
    fml_effort_rel=list(
      flagval(par, 1, c(378, 377, 383, 362)),
      fish_flags=matrix(flagval(par, -(ffrange), fml_effort_rel_fshflags)$value,
             nrow=length(ffrange), byrow=T,
             dimnames = list(paste('fsh', ffrange), paste('flag', fml_effort_rel_fshflags)))),
    catchability=list(
      flagval(par, 2, c(57, 104, 125, 126, 127, 156)),
      fish_flags=matrix(flagval(par, -(ffrange), catchability_fshflags)$value,
             nrow=length(ffrange), byrow=T,
             dimnames = list(paste('fsh', ffrange), paste('flag', catchability_fshflags)))),
    selectivity=list(
      rbind(flagval(par, 1, c(323, 74)), 
            flagval(par, 2, c(36, 193))),
      fish_flags=matrix(flagval(par, -(ffrange), selectivity_fshflags)$value,
             nrow=length(ffrange), byrow=T,
             dimnames = list(paste('fsh', ffrange), paste('flag', selectivity_fshflags)))),
    tag=list(
      rbind(flagval(par, 1, c(111, 305, 306, 358, 325, 326, 33)), 
            flagval(par, 2, c(96,100,198))),
      fish_flags=matrix(flagval(par, -(ffrange), tag_fshflags)$value,
                        nrow=length(ffrange), byrow=T,
                        dimnames = list(paste('fsh', ffrange), paste('flag', tag_fshflags))),
      tag_flags=matrix(flagval(par, -(10000 + ttrange), 1:10)$value,
                       nrow=length(ttrange), byrow=T,
                       dimnames = list(paste('fsh', ttrange), paste('flag', 1:10))))
      )
}


#' Diff Flags
#'
#' Show differences in flag settings between two model runs.
#'
#' @param par1 MFCL flags from model run 1.
#' @param par2 MFCL flags from model run 2.
#' @param all whether to include flags that are only specified in one of the
#'        model runs.
#' @param flaglist optional filename to use instead of the built-in
#'        \file{flaglist.csv} lookup table.
#' @param \dots passed to \code{diffFlags}.
#'
#' @details
#' The \code{par1} and \code{par2} objects can be any of the following:
#' \enumerate{
#' \item folder containing a \verb{par} file
#' \item filename of a \verb{par} file
#' \item \code{MFCLPar} object
#' \item \code{MFCLFlags} object
#' \item \code{data.frame} containing flag settings
#' }
#'
#' @return
#' A data frame showing flag settings where par1 and par2 are different, along
#' with a column showing the meaning of each flag.
#'
#' @note
#' \code{flagDiff} is an older name of this function. To support legacy scripts,
#' a call to the old function is simply forwarded to \code{diffFlags}.
#'
#' @seealso
#' This function calls \code{\link{flagMeaning}} to add the column showing the
#' meaning of each flag.
#'
#' \code{\link{diffFlagsStepwise}} shows differences in flag settings between
#' stepwise model runs.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' data(par)
#' par1 <- par2 <- par
#'
#' # Different flag value
#' flags(par2)[20,"value"] <- 12
#' diffFlags(par1, par2)
#'
#' # When flag is specified in par1 but not in par2
#' flags(par1) <- rbind(flags(par1), c(-10269, 1, 1))
#' diffFlags(par1, par2)             # default is to show par2 as NA
#' diffFlags(par1, par2, all=FALSE)  # all=FALSE omits such comparisons
#'
#' @export

diffFlags <- function(par1, par2, all=TRUE, flaglist=NULL) {

  flags1 <- flagExtract(par1)
  flags2 <- flagExtract(par2)

  # Combine
  flags <- merge(flags1, flags2, by=c("flagtype", "flag"), all=all)
  names(flags) <- c("flagtype", "flag", "par1", "par2")

  # Compare
  notsame <- is.na(flags$par1) | is.na(flags$par2) | flags$par1 != flags$par2
  diffs <- flags[notsame,]
  diffs <- diffs[order(-diffs$flagtype, diffs$flag),]
  rownames(diffs) <- NULL

  # Add column with meaning
  diffs <- flagMeaning(diffs, flaglist=flaglist)

  diffs
}

#' @rdname diffFlags

flagDiff <- function(...) {
  diffFlags(...)
}


#' Flag Meaning
#'
#' Show the meaning of flags, based on a lookup table.
#'
#' @param flags MFCL flags from a model run.
#' @param flaglist optional filename to use instead of the built-in
#'        \file{flaglist.csv} lookup table.
#'
#' @details
#' The \code{flags} object can be any of the following:
#' \enumerate{
#' \item folder containing a \verb{par} file
#' \item filename of a \verb{par} file
#' \item \code{MFCLPar} object
#' \item \code{MFCLFlags} object
#' \item \code{data.frame} containing flag settings
#' }
#'
#' @return
#' A data frame with the same columns as \code{flags} plus a column called
#' \code{meaning}.
#'
#' @seealso
#' \code{\link{diffFlags}} calls this function to show the meaning of flags that
#' are different between two model runs.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' data(par)
#' flagMeaning(par)
#'
#' @export

flagMeaning <- function(flags, flaglist=NULL) {

  # Extract flags
  flags <- flagExtract(flags)

  # Prepare flag list
  if(is.character(flaglist))
    flaglist <- read.csv(flaglist)
  if(is.null(flaglist))
    flaglist <- read.csv(system.file(package="FLR4MFCL",
                                     "flaglist/flaglist.csv"))

  # Look up flag meaning
  lookup <- function(flagtype, flag, flaglist)
  {
    flagtype <- as.integer(flagtype)
    flag <- as.integer(flag)
    if(flagtype == 1)
      flaglist[flag, "parest_flags"]
    else if(flagtype == 2)
      flaglist[flag, "age_flags"]
    else if(flagtype %in% -(1:999))
      flaglist[flag, "fish_flags"]
    else
      ""
  }

  # Add column with meaning
  flags$meaning <- character(nrow(flags))
  for(i in seq_len(nrow(flags)))
    flags$meaning[i] <- lookup(flags$flagtype[i], flags$flag[i], flaglist)

  flags
}


#' Diff Flags Stepwise
#'
#' Show differences in flag settings between stepwise model runs.
#'
#' @param stepdir directory containing model runs in subdirectories.
#' @param models optional vector of directory names to manually specify stepwise
#'        models to compare.
#' @param labels optional vector of short labels to describe the stepwise
#'        models.
#' @param quiet whether to suppress the on-screen reporting of reading files.
#' @param \dots passed to \code{diffFlags}.
#'
#' @details
#' Generally, the user only needs to specify \code{stepdir}. If this top
#' directory contains stepwise model runs as subdirectories, then the default
#' values of \code{models} and \code{labels} will infer the correct paths and
#' model names.
#'
#' If the stepwise model runs are not organized in a straightforward way, the
#' \code{models} and \code{labels} arguments can be passed explicitly.
#'
#' @return
#' A list of data frames showing differences in flag settings between stepwise
#' model runs.
#'
#' @seealso
#' \code{\link{diffFlags}} shows differences in flag settings between two model
#' runs.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' \dontrun{
#' yft_dir <- "//penguin//assessments/yft/2020_review/analysis/stepwise"
#' yft_diffs <- diffFlagsStepwise(yft_dir)
#' lapply(yft_diffs, nrow)  # show number of flags changed in each step
#' lapply(yft_diffs, head)  # peek at the first 6 flags changes in each step
#'
#' # Unusual directory structure of BET 2020 stepwise models
#' bet_dir <- "//penguin/assessments/bet/2020/2020_stepwise"
#' bet_models <- file.path(dir(bet_dir, full.names=TRUE), "10N")
#' bet_labels <- dir(bet_dir)
#' bet_diffs <- diffFlagsStepwise(bet_dir, bet_models, bet_labels)
#' lapply(bet_diffs, nrow)
#' lapply(bet_diffs, head)
#' }
#'
#' @export

diffFlagsStepwise <- function(stepdir, models=dir(stepdir, full.names=TRUE),
                              labels=basename(models), quiet=FALSE, ...) {

  # Find models in stepwise folder
  models <- models[dir.exists(models)]  # only directories
  if(length(models) < 2)
    stop("fewer than 2 models in stepwise folder, nothing to diff")

  # Import each model once
  parobj <- list()
  for(i in seq_len(length(models))) {
    if(!quiet)
      cat("** Reading ", basename(models[i]), "/", sep="")
    parfile <- finalPar(models[i], quiet=quiet)
    parobj[[i]] <- read.MFCLFlags(parfile)
  }

  # Compare flags
  diffs <- list()
  for(i in seq_len(length(models)-1))
  {
    diffs[[i]] <- diffFlags(parobj[[i]], parobj[[i+1]], ...)
    names(diffs)[i] <- paste(labels[i], "vs.", labels[i+1])
  }

  diffs
}


# Get flags from anything: folder -> file -> flags -> data.frame

flagExtract <- function(flags) {

  if(is.character(flags) && dir.exists(flags))
    flags <- finalPar(flags, quiet=TRUE)
  if(is.character(flags) && file.exists(flags))
    flags <- read.MFCLFlags(flags)
  if(isS4(flags))
    flags <- flags(flags)
  flags
}


#' Flag Sort
#'
#' Sort flags by flagtype and flagnumber
#'
#' @param flags dataframe of MFCL flags from MFCLPar object.
#'
#' @return
#' A data frame of sorted flag settings
#'
#' @seealso
#' \code{\link{diffFlags}} calls this function to show the meaning of flags that
#' are different between two model runs.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' data(par)
#' flagSort(flags(par))
#'
#' @export

flagSort <- function(flags){

  if(!is.data.frame(flags))
    stop("flags is not a data frame")

  # ftypes <- unique(flags$flagtype)
  sortedparestflags <- subset(flags, flagtype==1)[order(subset(flags, flagtype==1)$flag),]
  sortedageflags    <- subset(flags, flagtype==2)[order(subset(flags, flagtype==2)$flag),]
  sortedfishflags   <- subset(flags, flagtype%in%c(-1:-999))[order(abs(subset(flags, flagtype%in%c(-1:-999))$flagtype),
                                                                   subset(flags, flagtype%in%c(-1:-999))$flag),]
  sortedtagflags    <- subset(flags, flagtype%in%c(-10000:-99999))[order(abs(subset(flags, flagtype%in%c(-10000:-99999))$flagtype),
                                                                         subset(flags, flagtype%in%c(-10000:-99999))$flag),]
  sortedregionflags <- subset(flags, flagtype%in%c(-100000:-999999))[order(abs(subset(flags, flagtype%in%c(-100000:-999999))$flagtype),
                                                                           subset(flags, flagtype%in%c(-100000:-999999))$flag),]

  sortedflags <- rbind(sortedparestflags, sortedageflags, sortedfishflags, sortedtagflags, sortedregionflags)
  return(sortedflags)
}




#' parestflag
#'
#' get parest flag settings
#'
#' @param par object of class MFCLFlag()
#' @param flags numeric vector of parest flag number(s).
#'
#' @description 
#' A simple wrapper function for \code{\link{flagval}}
#' 
#' @return
#' A data frame of sorted flag settings
#'
#' @seealso
#' \code{\link{flagval}} calls this function to retrieve flag settings.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' data(par)
#' parestflag(par, c(1,20))
#'
#' @export

setGeneric('parestflag', function(x, flags, ...) standardGeneric('parestflag')) 
setMethod('parestflag', signature(x='MFCLFlags'),function(x, flags){ flagval(x, 1, flags)})
          

#' ageflag
#'
#' get age flag settings
#'
#' @param par object of class MFCLFlag()
#' @param flags numeric vector of age flag number(s).
#'
#' @description 
#' A simple wrapper function for \code{\link{flagval}}
#' 
#' @return
#' A data frame of sorted flag settings
#'
#' @seealso
#' \code{\link{flagval}} calls this function to retrieve flag settings.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' data(par)
#' ageflag(par, c(32,92))
#'
#' @export

setGeneric('ageflag', function(x, flags, ...) standardGeneric('ageflag')) 
setMethod('ageflag', signature(x='MFCLFlags'),function(x, flags){ flagval(x, 1, flags)})



#' Get Fish Flag Settings
#'
#' A simple wrapper function for \code{\link{flagval}}.
#'
#' @param x object of class \code{MFCLFlags}.
#' @param flags numeric vector of fish flag number(s).
#' @param \dots currently ignored.
#'
#' @return
#' A data frame of sorted flag settings.
#'
#' @seealso
#' \code{\link{flagval}} calls this function to retrieve flag settings.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' data(par)
#' fishflag(par, c(1,15))
#'
#' @export

setGeneric('fishflag', function(x, flags, ...) standardGeneric('fishflag')) 

#' @rdname fishflag

setMethod('fishflag', signature(x='MFCLFlags'),
          function(x, flags){ 
            ff <- sort(unique(subset(flags(x), flagtype<0 & flagtype>-9999)$flagtype), decreasing = TRUE)
            flagval(x, ff, flags)
            })


#' tagflag
#'
#' get region flag settings
#'
#' @param par object of class MFCLFlag()
#' @param flags numeric vector of tag flag number(s).
#'
#' @description 
#' A simple wrapper function for \code{\link{flagval}}
#' 
#' @return
#' A data frame of sorted flag settings
#'
#' @seealso
#' \code{\link{flagval}} calls this function to retrieve flag settings.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' data(par)
#' tagflag(par, c(1))
#'
#' @export

setGeneric('tagflag', function(x, flags, ...) standardGeneric('tagflag')) 

setMethod('tagflag', signature(x='MFCLFlags'),
          function(x, flags){ 
            ff <- sort(unique(subset(flags(x), flagtype<= -9999 & flagtype> -99999)$flagtype), decreasing = TRUE)
            flagval(x, ff, flags)
          })




#' regionflag
#'
#' get region flag settings
#'
#' @param par object of class MFCLFlag()
#' @param flags numeric vector of region flag number(s).
#'
#' @description 
#' A simple wrapper function for \code{\link{flagval}}
#' 
#' @return
#' A data frame of sorted flag settings
#'
#' @seealso
#' \code{\link{flagval}} calls this function to retrieve flag settings.
#'
#' \code{\link{read.MFCLFlags}} reads flag settings from a \verb{par} file.
#'
#' @examples
#' data(par)
#' regionflag(par, c(1))
#'
#' @export

setGeneric('regionflag', function(x, flags, ...) standardGeneric('regionflag')) 

setMethod('regionflag', signature(x='MFCLFlags'),
          function(x, flags){ 
            ff <- sort(unique(subset(flags(x), flagtype<= -99999)$flagtype), decreasing = TRUE)
            flagval(x, ff, flags)
          })
robscott3/FLR4MFCL documentation built on Feb. 12, 2024, 1:44 p.m.