R/plot_util.R

In natgoodman/toutr: Exploring Statistical Issues Inspired by Taxpayer Outreach

#################################################################################
##
## Author:  Nat Goodman
## Created: 20-03-22
##          from plot_nudge.R created 20-03-19
##          from misisg/R/plot.R created 19-01-09
##          uses code from repwr/R/plot.R created 18-05-03
##
## Copyright (C) 2019 Nat Goodman.
## 
## Plot utility functions
##
## This software is open source, distributed under the MIT License. See LICENSE
## file at https://github.com/natgoodman/NewPro/FDR/LICENSE 
##
#################################################################################
library(RColorBrewer);
## ---- Plot Utility Functions ----
## auto-scale title
cex_title=function(title) {
  xyplt=par('plt');                     # dimensions of plot region
  xplt=xyplt[2]-xyplt[1];               # width of plot region
  min(1,xplt/strwidth(title,units='fig'));
}

## draw one or more legends. adapted from misig/multi_legend, repwr/ragm_legend
## legends is list of legend.args - arguments to my legend wrapper
##   or equivalently base R legend
## where, x, y are starting position
##   where can be keyword (eg, 'right'), coordinate (used as x), or vector of x, y
##   vector is typically from previous call
## others used as defaults in each legend
add_legend=
  function(legends,where=NULL,x=NULL,y=NULL,cex=0.8,bty='n',
           title=NULL,title.col='black',
           col='black',lty='solid',lwd=1,labels=NULL,legend=labels,...) {
    if (length(where)==1) x=where;
    if (length(where)==2) {x=where[1]; y=where[2];}
    default.args=
      list(cex=cex,bty=bty,title=title,title.col=title.col,col=col,lty=lty,lwd=lwd,
           ...);
    if (missing(legends)) do.call(legend_,c(list(x=x,y=y,legend=legend),default.args))
    else {
      sapply(legends,function(legend.args) {
        if (is.null(legend.args)) return();
        legend.args=fill_defaults(default.args,c(list(x=x,y=y),legend.args));
        where.next=do.call(legend_,legend.args);
        ## <<- assigns to variables in outer scope, ie, function scope
        ##   from stackoverflow.com/questions/13640157. Thanks!
        ## could also use, eg, assign('x',where.next[1],envir=parent.frame(n=3))
        x<<-where.next[1];
        y<<-where.next[2];
      })}
    ## invisible();
    c(x,y);
  }
## draw one legend. wrapper for base R legend 
## adapted from misig/plotm_legend, repwr/mesr_legend
## labels and legend are synonyms
legend_=
  function(x,y,cex=0.8,bty='n',title=NULL,title.col='black',
           col='black',lty='solid',lwd=1,labels=NULL,legend=labels,...) {
    if (is.null(legend)) return();      # nothing to draw
    where.next=graphics::legend(x,y,bty=bty,legend=legend,cex=cex,col=col,lwd=lwd,lty=lty,
                                title=title,title.col=title.col,...);
    x=where.next$rect$left;
    y=where.next$rect$top-where.next$rect$h;
    c(x,y);
  }
## make colors from RColorBrewer palettes
## palettes - RColorBrewer palette names
## n - number of colors
## names - names to index colors. if set, overrides n
## skip - for seqeuential palettes, number of colors to skip  - 1st two usually too light
## dark.first - for seqeuential palettes, reverse so darker colors first
col_brew=function(palettes,n=0,names=NULL,skip=2,dark.first=TRUE) {
  if (is.null(palettes)||(missing(n)&&missing(names))) return(NULL);
  bad=palettes %notin% rownames(brewer.pal.info);
  if (any(bad)) stop(paste('Invalid palette name(s):',paste(collapse=', ',palettes[bad])));
  if (!is.null(names)) n=length(names);
  n.pal=length(palettes);
  ns=if(n.pal==1) n else as.integer(table(cut(1:n,n.pal)));
  ## col=do.call(c,lapply(1:length(palettes),
  ##                      function(i) col_brew_(palettes[i],ns[i],skip,dark.first)));
  col=do.call(c,col_brew_(palettes,ns,skip,dark.first));
  # if too many colors, use 1st n
  if (n<length(col)) col=head(col,n);
  setNames(col,names);
}
col_brew_=Vectorize(function(pal,n,skip,dark.first) {
  if (n==0) return(NULL);
  if (brewer.pal.info[pal,'category']!='seq') m=n else m=n+skip;
  m=min(m,brewer.pal.info[pal,'maxcolors']);
  m=max(3,m);                         # all palettes have min 3 colors
  col=brewer.pal(m,pal);
  if (brewer.pal.info[pal,'category']=='seq') {
    if (skip>0) col=tail(col,-skip);
    if (dark.first) col=rev(col);
  }
  ## if want more colors than in palette, colorRampPalette will make more
  if (n>length(col)) col=colorRampPalette(col)(n);
  col;
},vectorize.args=cq(pal,n),SIMPLIFY=FALSE,USE.NAMES=FALSE);

## empty plot - just title & axes
plotempty=
  function(title='',cex.title='auto',xlab='x',ylab='y',xlim=c(0,1),ylim=c(0,1),
           xaxp=c(xlim,1),yaxp=c(ylim,1),...) {
    if (is.null(cex.title)|cex.title=='auto') cex.title=cex_title(title);
    plot(x=NULL,y=NULL,type='n',main=title,cex.main=cex.title,xlab=xlab,ylab=ylab,
         xlim=xlim,ylim=ylim,xaxp=xaxp,yaxp=yaxp,...);
    xylim=par('usr');                   # limits of disply region
    xmid=mean(xylim[1:2]);
    ymid=mean(xylim[3:4]);
    text(xmid,ymid,'PLOT DELIBERATELY LEFT BLANK',adj=c(0.5,0.5));
    invisible();
}
## helper functions to plot horizontal and vertical line segments
vhline=function(vline=NULL,hline=NULL,vlab=TRUE,hlab=TRUE,vhdigits=2,col=NA,cex=0.75,...) {
  xylim=par('usr');
  vline=vline[which(between(vline,xylim[1],xylim[2]))];
  hline=hline[which(between(hline,xylim[3],xylim[4]))];
  abline(v=vline,h=hline,col=col,...);
  ## write vhline values along axes
  vline=vline[vlab];
  if (length(vline)>0)
    mtext(round(vline,vhdigits),side=1,at=vline,col=col,line=0.25,cex=cex*par('cex'));
  hline=hline[hlab];
  if (length(hline)>0)
    mtext(round(hline,vhdigits),side=2,at=hline,col=col,line=0.25,cex=cex*par('cex'));
}
hline=
  function(y,x0=0,x,col='black',lty='solid',lwd=1,cex=0.75,text=NULL,
           label=list(text=text,side=2,at=y,col=col,line=0.25,cex=cex*par('cex'),las=1)) {
    segments(x0=x0,x1=x,y0=y,y1=y,col=col,lty=lty,lwd=lwd);
    if (!is.null(text)) do.call(mtext,label);
  }
vline=
  function(x,y0=0,y,col='black',lty='solid',lwd=1,cex=0.75,text=NULL,
           label=list(text=text,side=1,at=x,col=col,line=0.25,cex=cex*par('cex'),las=1)) {
    segments(x0=x,x1=x,y0=y0,y1=y,col=col,lty=lty,lwd=lwd);
    if (!is.null(text)) do.call(mtext,label);
  }
## display color palette - from util.R
pal=function(col,border="light gray",...) {
 n=length(col)
 plot(0,0,type="n",xlim=c(0,1),ylim=c(0,1),axes=FALSE,xlab="",ylab="",...)
 rect(0:(n-1)/n,0,1:n/n,1,col=col,border=border)
}