#-------------------------------------------------------------------------------
# ** create.fleets.ctrl **
#
# Dorleta Garc?a - Azti Tecnalia
# 28/05/2013 10:42:07
#-------------------------------------------------------------------------------
#
# :: ARGUMENTS ::
#
# - ** fltsnames ** : character vector with fleet names
# - ** n.flts.stks ** : numeric vector with the same length as fltsnames with the declaration the stocks caugth by each of the fleets.
# - ** flts.stksnames **: character vector with length = sum(n.flts.stks), with the names of the stocks caught by the fleet,
# o the first n.flts.stks[1] elements correspond to the stocks caught by the first fleet in fltsnames
# o the following n.flts.stks[2] elements correspond to the stocks caught by the second fleet in fltsnames
# o and so on.
# - ** catch.threshold **: if(NULL) => 0.9 for all the stocks (NULL is the default)
# else it must be an FLQuant with dim = c(nstks,ny,1,ns,nit)
# - ** effort.models **: characted vector with the same length as fltsnames with the effort model followed by each of the fleet.
# the first element correspond with the effort model of the first fleet in fltsnames, the second with the second and so on.
# The default is NULL in which case 'fixedEffort' is used for **all** the fleets.
# - ** capital.models **: characted vector with the same length as fltsnames with the capital model followed by each of the fleet.
# the first element correspond with the capital model of the first fleet in fltsnames, the second with the second and so on.
# The default is NULL in which case 'fixedCapital' is used for **all** the fleets.
# - ** catch.models **: characted vector with the same length as sum(n.flts.stks) with the catch model followed by each of the fleet for each stock.
# the first element correspond with the catch model of the first fleet in fltsnames and the first stock in flts.stksnames, the second with the second and so on.
# The default is NULL in which case 'CobbDouglasAge' is used for **all** the fleets.
# - ** price.models **: characted vector with the same length as sum(n.flts.stks) with the price model followed by each of the fleet for each stock.
# the first element correspond with the price model of the first fleet in fltsnames and the first stock in flts.stksnames, the second with the second and so on.
# The default is NULL in which case 'fixedPrice' is used for **all** the fleets.
# - ** flq **: An flquant to give structure to the FLQuants to be used within the function,
# the dimensioan and dimnames in 'year', 'season' and 'iter' will be used to create the necessary FLQuants.
# - ...: Any extra arguments necessary in the model specific creators. '...' are extracted using 'list(...)', this generates a named list with the extra arguments.
# To assure the correct functioning the extra arguments must have a name, for example, elas = FLQuant(1,dimnames = DimsNms) and
# the creators for specific models must have to arguments 'res' and largs:
# o 'res': the element with the general structure created in the main function
# o 'larg': A named list with the elements necessary within the creator. For example if we use elas = FLQuant(1,dimnames = DimsNms)
# in the call to the main function within the specific creator this element will be used as 'largs$elas'.
#
create.fleets.ctrl <- function(fltsnames, n.flts.stks, flts.stksnames, catch.threshold = NULL, seasonal.share = NULL,
effort.models = NULL, capital.models = NULL, catch.models = NULL, price.models = NULL, flq, ...){
effort.models.available <- c('fixedEffort', 'SMFB', 'SSFB', 'MaxProfit')
catch.models.available <- c('CobbDouglasAge', 'CobbDouglasBio')
price.models.available <- c('fixedPrice', 'elasticPrice')
capital.models.available <- c('fixedCapital', 'SCD')
nfls <- length(fltsnames)
res <- vector('list', nfls + 2)
names(res) <- c('catch.threshold', 'seasonal.share', fltsnames)
stknms <- unique(flts.stksnames)
extra.args <- list(...) # a named list with the extra arguments in the call to the function, it'll contain the arguments for specific creators.
# Give default values to NULL elements.
if(is.null(catch.threshold)){ res[['catch.threshold']] <- FLQuant(0.9, dimnames = list(stock = stknms, year = dimnames(flq)[['year']],
season = dimnames(flq)[['season']], iter = dimnames(flq)[['iter']]))
}else{
res[['catch.threshold']] <- catch.threshold
}
# Seasonal share.
if(is.null(seasonal.share)){
res[['seasonal.share']] <- vector('list', length(unique(flts.stksnames)))
names(res[['seasonal.share']]) <- unique(flts.stksnames)
Dims <- c(list(fleet = fltsnames), dimnames(flq)[2:6])
for(i in 1: length(res[['seasonal.share']])) res[['seasonal.share']][[i]] <- FLQuant(1/dim(flq)[4], dimnames = Dims)
}
else{
res[['seasonal.share']] <- seasonal.share
}
if(is.null(effort.models)) effort.models <- rep('fixedEffort', nfls)
if(is.null(capital.models)) capital.models <- rep('fixedCapital', nfls)
if(is.null(catch.models)) catch.models <- rep('CobbDouglasAge', sum(n.flts.stks))
if(is.null(price.models)) price.models <- rep('fixedPrice', sum(n.flts.stks))
# check that all flq-s differ only in first (quant) dimension.
test.flqs <- lapply(c('flq', names(extra.args)[grep(pattern = 'flq', names(extra.args))]), get)
if(length(test.flqs)>1) if(!equal.flq.Dimnames(test.flqs, 2:5)) stop("All the input 'FLquant's must share 'year', 'unit', 'season', 'area' and 'iter' dimensions.")
# Check foo.models
# effort models
if(length(effort.models) != nfls) stop("'effort.models' must be NULL or must have the same length as fltsnames'")
if(!all(effort.models %in% effort.models.available)){
wmod <- effort.models[which(!(effort.models %in% effort.models.available))]
warning(paste(unique(wmod), collapse = ', ')," in 'effort.models' is not an internal FLBEIA effort model. If you want to use create.fleets.ctrl you must create, ", paste(paste('create', unique(wmod) ,'ctrl', sep = "."), collapse = ", ")," function.")
}
# catch models.
if(length(catch.models) != sum(n.flts.stks)) stop("'catch.models' must be NULL or must have the same length as stknames'")
if(!all(catch.models %in% catch.models.available)){
wmod <- catch.models[which(!(catch.models %in% catch.models.available))]
warning(paste(unique(wmod), collapse = ', ')," in 'catch.models' is not an internal FLBEIA catch model. If you want to use create.fleets.ctrl you must create, ", paste(paste('create', unique(wmod) ,'ctrl', sep = "."), collapse = ", ")," function.")
}
# price models.
if(length(price.models) != sum(n.flts.stks)) stop("'price.models' must be NULL or must have the same length as stknames'")
if(!all(price.models %in% price.models.available)){
wmod <- price.models[which(!(price.models %in% price.models.available))]
warning(paste(unique(wmod), collapse = ', ')," in 'price.models' is not an internal FLBEIA price model. If you want to use create.fleets.ctrl you must create, ", paste(paste('create', unique(wmod) ,'ctrl', sep = "."), collapse = ", ")," function.")
}
# capital models.
if(length(capital.models) != nfls) stop("'capital.models' must be NULL or must have the same length as stknames'")
if(!all(capital.models %in% capital.models.available)){
wmod <- capital.models[which(!(capital.models %in% capital.models.available))]
warning(paste(unique(wmod), collapse = ', ')," in 'capital.models' is not an internal FLBEIA capital model. If you want to use create.fleets.ctrl you must create, ", paste(paste('create', unique(wmod) ,'ctrl', sep = "."), collapse = ", ")," function.")
}
# Some check to test if declared number of stocks coincide with that used in the name declaration-
# if(length(nflsts.mtrs) != nfls) stop("The length of 'fltsnames' and 'nflts.mtrs' must coincide")
# if(sum(nflts.mtrs) != length(flts.mtrsnames)) stop("The total number of metiers declared in 'nflts.mtrs' must be equal to the length of 'flts.mtrsnames'.")
if(sum(n.flts.stks) != length(flts.stksnames)) stop("The total number of stocks declared in 'n.flts.stks' must be equal to the length of 'flts.stksnames'.")
if(length(effort.models) != nfls) stop("The length of 'effort.models' must coincide with the number of fleets")
if(length(capital.models) != nfls) stop("The length of 'capital.models' must coincide with the number of fleets")
names(effort.models) <- fltsnames
names(capital.models) <- fltsnames
names(n.flts.stks) <- fltsnames
names(price.models) <- flts.stksnames
names(catch.models) <- flts.stksnames
# Create the fleet/metier/stock GENERAL structure in res.
k1 <- 1
k2 <- 1
for(f in fltsnames){ # fleet structure
res[[f]] <- vector('list', n.flts.stks[f] + 2) # minimum length
names(res[[f]]) <- c('effort.model', 'capital.model', flts.stksnames[k1:(k1 + n.flts.stks[f] - 1)])
res[[f]][['effort.model']] <- unname(effort.models[f])
res[[f]][['capital.model']] <- unname(capital.models[f])
for(st in flts.stksnames[k1:(k1+n.flts.stks[f]-1)]){ # stock structure.
res[[f]][[st]] <- vector('list', 2) # minimun length
names(res[[f]][[st]]) <- c('catch.model', 'price.model')
res[[f]][[st]][['catch.model']] <- unname(catch.models[k2])
res[[f]][[st]][['price.model']] <- unname(price.models[k2])
k2 <- k2 + 1
}
k1 <- k1 + n.flts.stks[f]
}
# Add the function specific elements by fleet/stock.
k1 <- 1
jf <- 1
for(f in fltsnames){ # fleet level functions; effort and capital models
effmodcreator <- paste('create', effort.models[f], 'ctrl', sep = '.')
capmodcreator <- paste('create', capital.models[f], 'ctrl', sep = '.')
res[[f]] <- eval(call(effmodcreator, resf = res[[f]], fltname = f, largs = extra.args))
res[[f]] <- eval(call(capmodcreator, resf = res[[f]], fltname = f, largs = extra.args))
for(st in flts.stksnames[k1:(k1+n.flts.stks[jf]-1)]){ # stock level functios: catch and price models.
catchmodcreator <- paste('create', catch.models[k1], 'ctrl', sep = '.')
pricemodcreator <- paste('create', price.models[k1], 'ctrl', sep = '.')
res[[f]][[st]] <- eval(call(catchmodcreator, resfst = res[[f]][[st]], fltname = f, stkname = st, largs = extra.args))
res[[f]][[st]] <- eval(call(pricemodcreator, resfst = res[[f]][[st]], fltname = f, stkname = st, largs = extra.args))
k1 <- k1 + 1
}
jf <- jf + 1
}
return(res)
}
#-------------------------------------------------------------------------------
# ** create.fixedEffort.ctrl **
#-------------------------------------------------------------------------------
create.fixedEffort.ctrl <- function(resf,fltname,largs) return(resf)
#-------------------------------------------------------------------------------
# ** create.SMFB.ctrl **
# extra args: restriction.fltname, effort.restr.fltname
#-------------------------------------------------------------------------------
create.SMFB.ctrl <- function(resf, fltname,largs){
# if NULL set default values
rest <- ifelse(is.null(largs[[paste('restriction', fltname,sep='.')]]), 'catch', largs[[paste('restriction', fltname,sep='.')]])
effrest <- ifelse(is.null(largs[[paste('effort.restr', fltname,sep='.')]]), 'max', largs[[paste('effort.restr', fltname,sep='.')]])
if(is.na(effrest)) warning("Effort restriction in (effort.rest argument) is missing for fleet, ", fltname, ", NA used, you MUST fill it otherwise SMFB will not work.")
resf[['restriction']] <- rest
resf[['effort.restr']] <- effrest
return(resf)
}
#-------------------------------------------------------------------------------
# ** create.MaxProfit.stkCnst.ctrl **
# extra args: stk.cnst.fltname
#-------------------------------------------------------------------------------
create.MaxProfit.ctrl <- function(resf,fltname,largs){
# if NULL set default values, the 3rd stock in resf list, it can happen that is not an stock name.
effort.restr <- ifelse(is.null(largs[[paste('effort.restr', fltname,sep='.')]]), NA, largs[[paste('effort.restr', fltname,sep='.')]])
rest <- ifelse(is.null(largs[[paste('restriction', fltname,sep='.')]]), NA, largs[[paste('restriction', fltname,sep='.')]])
if(is.na( effort.restr )) warning("Effort constraint in (effort.restr argument) is missing for fleet, ", fltname, ", NA used, you MUST fill it otherwise MaxProfit will not work.")
if(is.na( rest )) warning("Catch/landing restriction in (srestriction argument) is missing for fleet, ", fltname, ", NA used, you MUST fill it otherwise MaxProfit will not work.")
resf[['effort.restr']] <- effort.restr
resf[['restriction']] <- rest
return(resf)
}
#-------------------------------------------------------------------------------
# ** create.fixedCapital.ctrl **
#-------------------------------------------------------------------------------
create.fixedCapital.ctrl <- function(resf,fltname,largs) return(resf)
#-------------------------------------------------------------------------------
# ** create.SCD.ctrl **
# extra args: NONE
# This function does not contain extra arguments in fleets.ctrl, the
# extra information is stored in covars because they are system variables.
#-------------------------------------------------------------------------------
create.SCD.ctrl <- function(resf,fltname,largs) return(resf)
#-------------------------------------------------------------------------------
# ** create.fixedPrice.ctrl **
#-------------------------------------------------------------------------------
create.fixedPrice.ctrl <- function(resfst, fltname, stkname, largs) return(resfst)
#-------------------------------------------------------------------------------
# ** create.elasticPrice.ctrl **
# extra args: flq.stkname
#-------------------------------------------------------------------------------
create.elasticPrice.ctrl <- function(resfst, fltname, stkname, largs){
flq.stk <- largs[[paste('flq', stkname,sep = ".")]]
resfst[["pd.els"]] <- flq.stk
resfst[["pd.La0"]] <- flq.stk
resfst[["pd.Pa0"]] <- flq.stk
resfst[["pd.total"]] <- TRUE
warning( "You have selected 'elasticPrice' price model for fleet, '", fltname, "', and stock, '", stkname,
"'.\n Thus, you have to fill 'pd.els', 'pd.La0' and 'pd.Pa0' FLQuants in fleets.ctrl[['", fltname,"']][['", stkname,"']].\n", sep = "")
return(resfst)
}
#-------------------------------------------------------------------------------
# ** create.CobbDouglasAge.ctrl **
# ** create.CobbDouglasBio.ctrl **
#-------------------------------------------------------------------------------
create.CobbDouglasAge.ctrl <- create.CobbDouglasBio.ctrl <- function(resfst, fltname, stkname, largs) return(resfst)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.