R/Class_5_FLFleetExt.R

In flr/FLBEIA: Bio-Economic Impact Assessment of Management Strategies using FLR

#-------------------------------------------------------------------------------
# FLFleet extension  - Copy FLFleet from FLcore and replace:
#   FLFleet by FLFleetExt, FLMetier(s) by FLMetier(s)Ext and 
#   FLCatch(es) by FLCatch(es) sExt. 
# Dorleta GarcYYYa - 11/08/2010 10:31:07
#-------------------------------------------------------------------------------

## FLFleetExt		{{{
validFLFleetExt <- function(object) {

	# FLQuant slots share dims 3:5 ...
  dnames <- qapply(object, function(x) dimnames(x)[3:5])
	for(i in names(dnames))
		if(!identical(dnames[[i]], dnames[[1]]))
			return('All FLQuant slots must have the same dimensions')

  # ... and are consistent with metiers
  metdnames <- lapply(object@metiers, function(x)
    qapply(object, function(x) dimnames(x)[3:5]))
  for(i in seq(length=length(metdnames)))
    for(j in names(metdnames[[1]]))
	    if(!identical(metdnames[[i]][[j]], dnames[[1]]))
			  return('All FLQuant slots must have the same dimensions')

  # Year range of FLFleetExt covers all metiers
  metyears <- matrix(unlist(lapply(object@metiers, function(x)
    unlist(dims(x)[c('minyear', 'maxyear')]))), byrow=TRUE, ncol=2)

  if(any(dims(object)$minyear < metyears [,1]) |
    any(dims(object)$maxyear > metyears [,2]))
    return('Year range of fleet should encompass those of metier(s)')

  # iter is consistent between fleet and metiers
  if(any(dims(object)$iter != unlist(lapply(object@metiers, function(x) dims(x)$iter))))
    return('iter must be 1 or N across all slots and levels')

  # effshares must add up to one
  #effshs <- lapply(object@metiers, effshare)
  #if(length(effshs) > 1)
  #  for(i in 2:length(effshs))
  #    effshs[[1]] <- effshs[[1]] + effshs[[i]]
  #if(!isTRUE(all.equal(as.vector(effshs[[1]]), rep(1,prod(dim(effshs[[1]]))))))
  #  return('sum of effshare must add up to 1')

	return(TRUE)
}


#' 
#' @name FLFleetExt
#' @aliases FLFleetExt-class FLFleetExt FLFleetExt-methods
#' FLFleetExt,FLFleetExt-method
#' 
#' @title  FLFleetExt class and the methods to construct it.
#'
#' @description It extends the FLFleetExt class defined in FLFleet package. 
#' The only difference is that that the metiers slot is a FLMetiersExt object.
#' 
#' @details The FLFleetExt object contains a representation of a fishing fleet as constructed for the purposes of fleet dynamic modelling. 
#'    This includes information on effort, fixed-cost, capacity, crew-share, metiers and variable costs.
#' 
#' @param object,x An object of class FLQuant, missing, FLFleetExt, 
#'                 FLCatchExt, FLCatchesExt or FLMetierExt.
#' @param metier A name of one of the elements in FLMetiersExt object.
#' @param catch A name of one of the elements in FLCatchesExt object.
#' @param ... Other objects to be assigned by name to the class slots 
#' @param i,j subindices.
#' @param drop If TRUE, deletes the dimensions of an array which have only one level.
#' 
#' 
#' @return The constructors return an object of class FLFleetExt.
#' 
#' @slot effort An FLQuant with the effort of the fleet. The effort can have any units (e.g. number of fishing days, trips, hooks,...)
#' @slot fcost An FLQuant with the fixed costs of the fleet. 
#'             These costs should be given by vessel and the number of vessels by fleet must be included in the covars object.
#' @slot capacity An FLQuant with the capacity of the fleet. Same units as in slot effort must be used.
#' @slot crewshare An FLQuant with the crewshare of the fleet. Where crewshare is the percentage of revenues that goes to the crew.
#' @slot metiers A FLMetiersExt with information on the fleet's metiers.
#' @slot name The name of the stock.
#' @slot desc A description of the object.
#' @slot range The range as in other FLR objects: c("min","max","plusgroup","minyear","maxyear").
#'    

setClass('FLFleetExt',
	representation('FLComp',
		effort='FLQuant',
		fcost='FLQuant',
		capacity='FLQuant',
		crewshare ="FLQuant",
		metiers='FLMetiersExt'),
	prototype(name=character(0), desc=character(0),
		range= unlist(list(min=0, max=0, plusgroup=NA, minyear=1, maxyear=1)),
		effort=FLQuant(), fcost=FLQuant(), capacity=FLQuant(),
		crewshare=FLQuant(), metiers=FLMetiersExt()),
	validity=validFLFleetExt)
remove(validFLFleetExt)

#invisible(createFLAccesors("FLFleetExt", exclude=c('range', 'effort', 'name', 'desc')))	# }}}

# FLFleetExt
setGeneric('FLFleetExt', function(object, ...) standardGeneric('FLFleetExt'))



# FLFleetExt()		{{{
#' @aliases FLFleetExt,FLMetiersExt-method
#' @rdname FLFleetExt
setMethod('FLFleetExt', signature(object='FLMetiersExt'),
	function(object, ...)
	{
		args <- list(...)
		flqs <- unlist(lapply(args, is, 'FLQuant'))
		if(any(flqs))
			flqs <- FLQuant(NA,
				dimnames=c(dimnames(args[[names(flqs[flqs==TRUE])[1]]])[-6], list(iter=1)))
		else
			flqs <- FLQuant()
		res <- new('FLFleetExt', metiers=object, effort=flqs, fcost=flqs,
			capacity=flqs, crewshare=flqs, range=range(object))

		# extra arguments
		for (i in names(args))
			slot(res, i) <- args[[i]]
		return(res)
	}
)


#' @aliases FLFleetExt,FLMetierExt-method
#' @rdname FLFleetExt
setMethod('FLFleetExt', signature(object='FLMetierExt'),
	function(object, ...)
	{
		FLFleetExt(FLMetiersExt(met=object), ...)
	}
)

#' @aliases FLFleetExt,FLCatchesExt-method
#' @rdname FLFleetExt
setMethod('FLFleetExt', signature(object='FLCatchesExt'),
	function(object, ...)
	{
		FLFleetExt(FLMetiersExt(FLMetierExt(object)), ...)
	}
)

#' @aliases FLFleetExt,FLCatchExt-method
#' @rdname FLFleetExt
setMethod('FLFleetExt', signature(object='FLCatchExt'),
	function(object, ...)
	{
		FLFleetExt(FLMetiersExt(FLMetierExt(FLCatchesExt(object))), ...)
	}
)

#' @aliases FLFleetExt,FLFleetExt-method
#' @rdname FLFleetExt
setMethod('FLFleetExt', signature(object='FLFleetExt'),
	function(object, metier, catch, ...)
	{
    res <- object
    if(!missing(metier))
      res@metiers <- res@metiers[metier]
    if(!missing(catch))
      res@catches <- res@metiers[catch]

		return(res)
	}
)


#' @aliases FLFleetExt,FLFleetExt-missing
#' @rdname FLFleetExt
setMethod('FLFleetExt', signature(object='missing'),
	function(object, ...)
	{
		FLFleetExt(FLMetiersExt(FLMetierExt(FLCatchesExt(FLCatchExt()))), ...)
	}
)	# }}}

# summary	{{{
setMethod('summary', signature(object='FLFleetExt'),
	function(object, ...)
	{
		callNextMethod(object)
		cat("\n")
		cat("Metiers: ", "\n")
		# TODO What happens when object has no metiers/catches? IM 28.08.07
		for (i in names(object@metiers))
		{
			cat("\t", i, ":\n")
			
			for (j in names(object@metiers[[i]]@catches))
				cat("\t\t", j, ": [", dim(object@metiers[[i]]@catches[[j]]@landings.n),"]\n")
		}
	}
)
# }}}

# metier(fl, me)	{{{
setMethod('metier', signature(object='FLFleetExt', metier='ANY'),
	function(object, metier, ...)
		return(object@metiers[[metier]])
)
setReplaceMethod('metier', signature(object='FLFleetExt', metier='ANY', value='FLMetierExt'),
	function(object, metier, ..., value)
	{
		object@metiers[[metier]] <- value
		return(object)
	}
)	# }}}

# FLFleetExt accesors	{{{
createFleetExtAccesors('catch', catch, c(2:5), assigment=FALSE)
createFleetExtAccesors('catch.n', catch.n, c(2:5), assigment=FALSE)
createFleetExtAccesors('catch.wt', catch.wt, c(2:5), assigment=FALSE)
createFleetExtAccesors('catch.sel', catch.sel, c(2:5), assigment=FALSE)
createFleetExtAccesors('catch.q', catch.q)
createFleetExtAccesors('discards', discards)
createFleetExtAccesors('discards.n', discards.n)
createFleetExtAccesors('discards.wt', discards.wt)
createFleetExtAccesors('discards.sel', discards.sel)
createFleetExtAccesors('landings', landings)
createFleetExtAccesors('landings.n', landings.n)
createFleetExtAccesors('landings.wt', landings.wt)
createFleetExtAccesors('landings.sel', landings.sel)
createFleetExtAccesors('price', price)
# }}}

# revenue	{{{
setMethod('revenue', signature('FLCatchExt'),
	function(object)
    if(!all(is.na(landings.n(object))))
      return(quantSums(landings.n(object) * landings.wt(object) * price(object)))
    else
      return(landings(object) * price(object))
)
setMethod('revenue', signature('FLCatchesExt'),
	function(object, catch=unique(names(object)), ...)
		return(lapply(object, revenue))
)
setMethod('revenue', signature('FLMetierExt'),
  function(object, ...)
    return(revenue(object@catches, ...))
)
setMethod('revenue', signature('FLMetiersExt'),
  function(object, metier, catch, ...)
  {
  if(missing(catch) && missing(metier))
    return(TRUE)
  else if(missing(catch))
    revenue(metier(object, metier))
  else if(missing(metier))
    Reduce('+',lapply(object@metiers, revenue))
  else
    return(TRUE)
  }
)
setMethod('revenue', signature('FLFleetExt'),
  function(object, ...)
    return(revenue(object@metiers, ...))
) # }}}

## iter {{{
setMethod("iter", signature(obj="FLFleetExt"),
	  function(obj, iter)
	  {
		# FLQuant slots
		names <- names(getSlots(class(obj))[getSlots(class(obj))=="FLQuant"])
		for(s in names) 
		{
			if(dims(slot(obj, s))$iter == 1)
				slot(obj, s) <- iter(slot(obj, s), 1)
			else
				slot(obj, s) <- iter(slot(obj, s), iter)
		}
		# FLMetiersExt
		names <- names(obj@metiers)
		for (s in names)
			metier(obj, s) <- iter(metier(obj, s), iter)
		
		return(obj)
	  }
) # }}}

# catches(fl, me, ca)	{{{
setMethod('catches', signature(object='FLFleetExt'),
	function(object, ...)
		return(catches(object@metiers, ...))
)
setMethod('catches', signature(object='FLMetiersExt'),
	function(object, catch='missing', sum=FALSE, ...)
  {
    # No catch? OK if only one in object
    if(missing(catch))
      if(length(unique(unlist(lapply(object, function(x) names(x@catches))))) == 1)
        catch <- object[[1]]@catches[[1]]@name
      else
        stop('No catch was selected and object holds data for more than one catch')
    
    # identify metiers with this catch.
    idx <- unlist(lapply(object, function(x) any(catchNames(x) == catch)))

    # if index is numeric and only one metier, select from names
    if(length(object) == 1 & is.numeric(catch))
      catch <- catchNames(object)[catch]
    res <- lapply(object[idx], catches, catch=catch)
    
    if(length(res) > 1 && sum==TRUE)
    {
      res[1:2] <- mcf(res[[1]], res[[2]])
      res[[1]] <- addFLCatch(res[[1]], res[[2]])
      if(length(res) > 2)
        for(i in seq(3, length(res)))
        {
          res[[i]] <- mcf(res[[1]], res[[i]])[[2]]
          res[[1]] <- addFLCatch(res[[1]], res[[i]])
        }
      return(FLCatchesExt(res[[1]]))
    }
    return(FLCatchesExt(res))
  }
)
setMethod('catches', signature(object='FLMetierExt'),
	function(object, catch='missing', ...)
  {
		if(missing(catch))
      return(object@catches)
    if (length(catch) == 1)
      return(object@catches[[catch]])
    else
      return(object@catches[catch])
  }
)	# }}}

# catches<-(fl, ca)	{{{
setMethod('catches<-', signature(object='FLMetierExt', value='FLCatchExt'),
	function(object, catch, ..., value)
  {
    object@catches[[catch]] <- value
    return(object)
  }
)
setMethod('catches<-', signature(object='FLMetierExt', value='FLCatchesExt'),
	function(object, catch, ..., value)
  {
    object@catches <- value
    return(object)
  }
) # }}}

# FLMetierExt accesors for FLFleetExt {{{
setMethod('effshare', signature(object='FLMetiersExt'),
  function(object, metier=names(object))
  {
    if(length(metier) == 1)
      return(object[[metier]]@effshare)
    else
      return(FLQuants(lapply(object[metier], effshare)))
  }
)
setMethod('effshare', signature(object='FLFleetExt'),
  function(object, ...)
    return(effshare(object@metiers, ...))
)
setMethod('vcost', signature(object='FLMetiersExt'),
  function(object, metier=names(object))
  {
    if(length(metier) == 1)
      return(object[[metier]]@vcost)
    else
      return(FLQuants(lapply(object[metier], vcost)))
  }
)
setMethod('vcost', signature(object='FLFleetExt'),
  function(object, ...)
    return(vcost(object@metiers, ...))
)
# }}}

## dims {{{
setMethod("dims", signature(obj="FLFleetExt"),
  # Returns a list with different parameters
  function(obj, ...)
	{
		qnames <- names(getSlots(class(obj))[getSlots(class(obj))=="FLQuant"])
		return(list(
      metiers=names(obj@metiers),
      catches=unique(unlist(lapply(obj@metiers, function(x) names(x@catches)))),
      quant = quant(slot(obj, qnames[1])),
      min=min(as.numeric(unlist(lapply(obj@metiers, function(x) lapply(x@catches,
        function(x) dimnames(x@landings.n)[[1]][1]))))),
      max=max(as.numeric(unlist(lapply(obj@metiers, function(x) lapply(x@catches,
        function(x) dimnames(x@landings.n)[[1]][dim(x@landings.n)[1]]))))),
      minyear=min(as.numeric(unlist(lapply(obj@metiers, function(x) lapply(x@catches,
        function(x) dimnames(x@landings.n)[[2]][1]))))),
      maxyear=max(as.numeric(unlist(lapply(obj@metiers, function(x) lapply(x@catches,
        function(x) dimnames(x@landings.n)[[2]][dim(x@landings.n)[2]]))))),
      unit=unique(unlist(lapply(obj@metiers, function(x) lapply(x@catches,
        function(x) length(dimnames(x@landings.n)[[3]]))))),
      season=unique(unlist(lapply(obj@metiers, function(x) lapply(x@catches,
        function(x) length(dimnames(x@landings.n)[[4]]))))),
      area=unique(unlist(lapply(obj@metiers, function(x) lapply(x@catches,
        function(x) length(dimnames(x@landings.n)[[5]]))))),
      iter=max(unlist(lapply(obj@metiers, function(x) lapply(x@catches,
        function(x) qapply(x, function(x) length(dimnames(x)[[6]]))))))
    ))
    }
)    # }}}

## window    {{{
setMethod("window", signature(x="FLFleetExt"),
        function(x, start=dims(x)$minyear, end=dims(x)$maxyear, extend=TRUE, frequency=1) {
            
            
            resm <- vector('list', length(x@metiers))
            names(resm) <- names(x@metiers)
            
            for(mt in names(x@metiers)){
              
              y <- x@metiers[[mt]]
              
              resm[[mt]] <- FLMetierExt(name = y@name,
                                        desc = y@desc,
                                        gear = y@gear, 
                                        range = c(min = y@range['min'], y@range['max'], minyear = start,maxyear = end),
                                        effshare = window(y@effshare, start = start, end = end, extend = extend, frequency = frequency),
                                        vcost = window(y@vcost, start = start, end = end, extend = extend, frequency = frequency),
                                        catches = FLCatchesExt(window(y@catches, start = start, end = end, extend = extend, frequency = frequency)))   
              
            }
            
            
            res <- FLFleetExt(name = x@name,
                              desc = x@desc,
                              range = c(min = x@range['min'], x@range['max'], minyear = start,maxyear = end),
                              effort = window(x@effort, start = start, end = end, extend = extend, frequency = frequency),
                              capacity = window(x@capacity, start = start, end = end, extend = extend, frequency = frequency),
                              crewshare = window(x@crewshare, start = start, end = end, extend = extend, frequency = frequency),
                              fcost = window(x@fcost, start = start, end = end, extend = extend, frequency = frequency),
                              metiers = FLMetiersExt(resm))
            
            return(res)
          }
)	# }}}

## effort		{{{
setMethod("effort", signature(object="FLFleetExt", metier="missing"),
	function(object)
    return(slot(object, "effort")))

setMethod("effort", signature(object="FLFleetExt", metier="character"),
	function(object, metier)
    return(slot(object, "effort") * slot(metier(object, metier), "effshare")))

setReplaceMethod("effort", signature(object="FLFleetExt", value="FLQuant"),
	function(object, value)
  {
		slot(object, "effort") <- value
    return(object)
  })
# }}}

# catchNames {{{
#' @rdname FLCatchesExt
#' @aliases catchNames,FLCatchesExt
setMethod('catchNames', signature(object='FLCatchesExt'),
  function(object)
  {
    return(unname(unlist(lapply(object, catchNames))))
  }
)

#' @rdname FLCatchesExt
#' @aliases catchNames,FLMetierExt
setMethod('catchNames', signature(object='FLMetierExt'),
  function(object)
  {
    return(catchNames(object@catches))
  }
)

#' @rdname FLCatchesExt
#' @aliases catchNames,FLMetiersExt
setMethod('catchNames', signature(object='FLMetiersExt'),
  function(object)
  {
    return(unique(unlist(lapply(object, catchNames))))
  }
)

#' @rdname FLCatchesExt
#' @aliases catchNames,FLFleetExt
setMethod('catchNames', signature(object='FLFleetExt'),
  function(object)
  {
    return(catchNames(object@metiers))
  }
) 

#' @rdname FLCatchesExt
#' @aliases catchNames,FLFleetsExt
setMethod('catchNames', signature(object='FLFleetsExt'),
  function(object)
  {
    return(unique(unlist(lapply(object, catchNames))))
  }
) # }}}

# trim {{{
setMethod('trim', signature(x='FLFleetExt'),
  function(x, ...)
  {
    x <- callNextMethod()
    x@metiers <- lapply(x@metiers, trim, ...)
    return(x)
  }
) # }}}

# propagate {{{
setMethod('propagate', signature(object='FLFleetExt'),
  function(object, ...)
  {
    object <- qapply(object, propagate, ...)
    object@metiers <- lapply(object@metiers, propagate, ...)
    return(object)
  }
) # }}}

# computeCatch  {{{
setMethod('computeCatch', signature(object='FLCatchExt'),
  function(object)
    return(quantSums(catch.n(object) * catch.wt(object)))
)
setMethod('computeDiscards', signature(object='FLCatchExt'),
  function(object)
    return(quantSums(discards.n(object) * discards.wt(object)))
)
setMethod('computeLandings', signature(object='FLCatchExt'),
  function(object)
    return(quantSums(landings.n(object) * landings.wt(object)))
)

setMethod('computeCatch', signature(object='FLMetierExt'),
  function(object, catch=names(object@catches))
  Reduce('+',lapply(object@catches[catch], computeCatch))
)
setMethod('computeDiscards', signature(object='FLMetierExt'),
  function(object, catch=names(object@catches))
  lapply(object@catches[catch], computeDiscards)
)
setMethod('computeLandings', signature(object='FLMetierExt'),
  function(object, catch=names(object@catches))
  lapply(object@catches[catch], computeLandings)
)

setMethod('computeCatch', signature(object='FLFleetExt'),
  function(object, ...)
  lapply(object@metiers, computeCatch, ...)
)
setMethod('computeDiscards', signature(object='FLFleetExt'),
  function(object, ...)
  lapply(object@metiers, computeDiscards, ...)
)
setMethod('computeLandings', signature(object='FLFleetExt'),
  function(object, ...)
  lapply(object@metiers, computeLandings, ...)
) # }}}

# "[" and "[["             {{{
#' @rdname FLFleetExt
#' @aliases [,FLFleetExt,ANY,missing-method
setMethod("[", signature(x="FLFleetExt", i="ANY", j="missing"),
  function(x, i, drop=FALSE)
  {
	  if (missing(i))
      return(x)
    x@metiers <- x@metiers[i]
    return(x)
	}
)

#' @rdname FLFleetExt
#' @aliases [,FLFleetExt,ANY,ANY-method
setMethod("[", signature(x="FLFleetExt", i="ANY", j="ANY"),
  function(x, i, j, drop=FALSE)
  {
    if(!missing(i))
      x <- x[i]
    if(!missing(j))
      x@metiers <- lapply(x@metiers, '[', j)
    return(x)
	}
)


#' @rdname FLFleetExt
#' @aliases [[,FLFleetExt,ANY,missing-method
setMethod("[[", signature(x="FLFleetExt", i="ANY", j="missing"),
  function(x, i, drop=FALSE)
  {
	  if (missing(i))
      stop("invalid subscript type")
    return(x@metiers[[i]])
	}
) # }}}

# as.data.frame {{{
setMethod('as.data.frame', signature(x='FLFleetExt', row.names='missing',
  optional='missing'), function(x)
  {
    df <- callNextMethod()
    df <- cbind(df, metier='NA', catch='NA')

    for (i in 1:length(x@metiers))
    {
      df <- rbind(df, cbind(catch='NA', metier=names(x@metiers)[[i]],
        as.data.frame(x@metiers[[i]])))

      for (j in 1:length(x@metiers[[i]]@catches))
      df <- rbind(df, cbind(catch=names(x@metiers[[i]]@catches)[[j]],
        metier=names(x@metiers)[[i]], as.data.frame(x@metiers[[i]]@catches[[j]])))
    }
    return(df)
  }
) # }}}