R/kobe-shade.R

In flr/kobe: Tools for Scientific Fisheries Management Advice

##############################################################
#' @name shade
#' @title Creates Kobe II Strategy Matrices
#' @description
#' Creates latex tables with shading for inclusion in latex docs.
#' 
#' @aliases shade-method shade,numeric-method  shade,matrix-method shade,data.frame-method
#' 
#' @param   object   an object of class \code{vector,data.frame,...}
#' @param   breaks vector of breaks
#' @param   shades vector of colours for shading 
#' @param   pct adds percent sign
#' @param  ...	other arguments
#' @export
#' @docType methods
#' @rdname  shade
setMethod('shade', signature(object='numeric'),
          function(object,breaks=c(-0.1,50,60,70,80,90,100),
                     shades=c("\\cellcolor{gray100}","\\cellcolor{gray90}","\\cellcolor{gray80}","\\cellcolor{gray70}","\\cellcolor{gray60}","\\cellcolor{gray50}"),
                     pct="\\%",...){

  #Kobe II strategy matrices to be prepared by the SCRS should highlight in a similar format as
  #shown in Annex Table 2 a progression of probabilities over 50 % and in the range of 50-59 %, 60-
  #69 %, 70-79 %, 80-89 % and ??? 90 %.
  object=pmin(pmax(object,0)*100)         
  res   =data.frame("order"=seq(length(object)),object=round(object),"level"=cut(object,breaks))
  gry   =data.frame(level=attributes(unique(res$level))$levels,shades)
  res  =merge(res,gry,all.x=TRUE)
  res  =res[order(res$order),]
  
  res$object=paste(ac(round(res$object)),pct,sep="")
  
  res=with(res,paste(shades,object,sep=" "))
  
  return(res)})

setMethod('shade', signature(object='data.frame'),
          function(object,breaks =c(-0.1,50,60,70,80,90,100),
                   shades=c("\\cellcolor{gray100}","\\cellcolor{gray90}","\\cellcolor{gray80}","\\cellcolor{gray70}","\\cellcolor{gray60}","\\cellcolor{gray50}"),
                   pct="\\%",...){

     as.data.frame(apply(object,2,shade,breaks=breaks,shades=shades,pct=pct))
     })

# setMethod('shade', signature(object='cast_df'),
#           function(object,breaks =c(-0.1,50,60,70,80,90,100),
#                    shades=c("","\\cellcolor{gray90}","\\cellcolor{gray80}","\\cellcolor{gray70}","\\cellcolor{gray60}","\\cellcolor{gray50}"),
#                    pct="\\%",...){
#             
#             as.data.frame(apply(object,2,shade,breaks=breaks,shades=shades,pct=pct))})
setMethod('shade', signature(object='matrix'),
          function(object,breaks =c(-0.1,50,60,70,80,90,100),
                   shades=c("\\cellcolor{gray100}","\\cellcolor{gray90}","\\cellcolor{gray80}","\\cellcolor{gray70}","\\cellcolor{gray60}","\\cellcolor{gray50}"),
                   pct="\\%",...){

     apply(object,2,shade,breaks=breaks,shades=shades,pct=pct)})

setMethod('kobe2sm', signature(object='data.frame'),
          function(object,cex   =1.0,
                         image  =list(levels=seq(0.0,1.0,0.05),
                                      col   =c(colorRampPalette(c("red4","red"))(12),colorRampPalette(c("yellowgreen","darkgreen"))(8))),
                         contour=list(levels=c(.6,.7,1.0,.9),
                                      col   =c("black"))){
                 
    nms   =dimnames(object)[[2]]
    nPlots=length(nms[nms %in% c("overFishing","overFished","green")])
                 
    ops<-par(mfrow=c(nPlots,1), mex=.5,mai=c( 0.5, 0.75 ,.750, 0.1),cex=par()$cex)
    
    res=list()
    if ("overFishing" %in% nms){
       x=transform(object, NotOverFishing=as.numeric(1-object[,"overFishing"]))[,c(nms[1:2],"NotOverFishing")]
       res[["F"]]    =kobe2smFn(x, image=image,contour=contour)
       mtext(expression(plain(P) (F<=F[MSY])),line=3, cex=cex)
       }
    if ("overFished" %in% nms){
       x=transform(object, NotOverFished=as.numeric(1-object[,"overFished"]))[,c(nms[1:2],"NotOverFished")]
       res[["SSB"]]  =kobe2smFn(x, image=image,contour=contour)
       mtext(expression(plain(P) (SSB>=SSB[MSY])),line=3, cex=cex)
       }
    if ("green" %in% nms){
       res[["Joint"]]=kobe2smFn(cbind(object[,c(1:2)],object[,"green"]), image=image,contour=contour)
       mtext(expression(plain(P) (F<=F[MSY]) %*% plain(P)(SSB>=SSB[MSY])),line=3, cex=cex)
       }

    par(mfrow=ops$mfrow,mex=ops$mex,mai=ops$mai,cex=ops$cex)

    invisible(res)})