R/variousPlottingHelperFunctions.R

In jniedballa/camtrapR: Camera Trap Data Management and Preparation of Occupancy and Spatial Capture-Recapture Analyses

# for function activityRadial

# the following 3 functions were adapted from package "plotrix" version 3.7-4
#   radial.plot
#   radial.grid
#   boxed.labels

# thanks to Jim Lemon et al.!


.radial.plot<-function(lengths,radial.pos=NULL,labels=NA,label.pos=NULL,
                       radlab=FALSE,start=0,clockwise=FALSE,rp.type="r",label.prop=1.1,main="",
                       xlab="",ylab="",line.col=par("fg"),lty=par("lty"),lwd=par("lwd"),
                       mar=c(2,2,3,2),show.grid=TRUE,show.grid.labels=4,show.radial.grid=TRUE,
                       rad.col="gray",grid.col="gray",grid.bg="transparent",grid.left=FALSE,
                       grid.unit=NULL,point.symbols=1,point.col=par("fg"),show.centroid=FALSE,
                       radial.lim=NULL,radial.labels=NULL,boxed.radial=FALSE,poly.col=NA,
                       add=FALSE,...) {
  
  if(is.null(radial.lim)) radial.lim<-range(lengths)
  length.dim<-dim(lengths)
  if(is.null(length.dim)) {
    npoints<-length(lengths)
    nsets<-1
    lengths<-matrix(lengths,nrow=1)
  }
  else {
    npoints<-length.dim[2]
    nsets<-length.dim[1]
    lengths<-as.matrix(lengths)
  }
  lengths<-lengths-radial.lim[1]
  lengths[lengths<0]<-NA
  if(is.null(radial.pos))
    radial.pos<-seq(0,pi*(2 - 2 * (rp.type != "l")/npoints),length.out=npoints)
  radial.pos.dim<-dim(radial.pos)
  if(is.null(radial.pos.dim))
    radial.pos<-matrix(rep(radial.pos,nsets),nrow=nsets,byrow=TRUE)
  else radial.pos<-as.matrix(radial.pos)
  if(rp.type == "l" && clockwise == TRUE) start<-pi/2
  if(clockwise) radial.pos<--radial.pos
  if(start) radial.pos<-radial.pos+start
  if(show.grid) {
    if(length(radial.lim) < 3) grid.pos<-pretty(radial.lim)
    else grid.pos<-radial.lim
    if(grid.pos[1] < radial.lim[1]) grid.pos<-grid.pos[-1]
    maxlength<-max(grid.pos-radial.lim[1])
    angles<-seq(0,1.96*pi,by=0.04*pi)
  }
  else {
    grid.pos<-NA
    maxlength<-diff(radial.lim)
  }
  oldpar<-par("xpd","mar","pty")
  if(!add) {
    par(mar=mar,pty="s")
    plot(c(-maxlength,maxlength),c(-maxlength,maxlength),type="n",axes=FALSE,
         main=main,xlab=xlab,ylab=ylab)
    if(is.null(label.pos)) {
      if(is.null(labels)) nlpos<-ifelse(npoints > 8,8,npoints)
      else {
        if(is.na(labels[1])) nlpos<-ifelse(npoints > 8,8,npoints)
        else nlpos<-length(labels)
      }
      label.pos<-seq(0,pi*(2-2/nlpos),length.out=nlpos)
    }
    if(show.grid) {
      .radial.grid(labels=labels,label.pos=label.pos,radlab=radlab,
                  radial.lim=radial.lim,start=start,clockwise=clockwise,
                  label.prop=label.prop,grid.pos=grid.pos,rad.col=rad.col,
                  grid.col=grid.col,grid.bg=grid.bg,
                  show.radial.grid=show.radial.grid)
    }
  }
  par(xpd=TRUE)
  # stretch everything out to the correct length
  if(length(line.col) < nsets) line.col<-1:nsets
  if(length(rp.type) < nsets) rp.type<-rep(rp.type,length.out=nsets)
  if(length(point.symbols) < nsets)
    point.symbols<-rep(point.symbols,length.out=nsets)
  if(length(point.col) < nsets) point.col<-rep(point.col,length.out=nsets)
  if(length(poly.col) < nsets) poly.col<-rep(poly.col,length.out=nsets)
  if(length(lty) < nsets) lty<-rep(lty,length.out=nsets)
  if(length(lwd) < nsets) lwd<-rep(lwd,length.out=nsets)
  for(i in 1:nsets) {
    if(nsets > 1) {
      linecol<-line.col[i]
      polycol<-poly.col[i]
      pointcol<-point.col[i]
      pointsymbols<-point.symbols[i]
      ltype<-lty[i]
      lwidth<-lwd[i]
    }
    else {
      linecol<-line.col
      polycol<-poly.col
      pointcol<-point.col
      pointsymbols<-point.symbols
      ltype<-lty
      lwidth<-lwd
    }
    # split up rp.type if there is a combination of displays
    rptype<-unlist(strsplit(rp.type[i],""))
    if(match("s",rptype,0)) {
      if(is.null(pointsymbols)) pointsymbols<-i
      if(is.null(pointcol)) pointcol<-i
    }
    # get the vector of x positions
    xpos<-cos(radial.pos[i,])*lengths[i,]
    # get the vector of y positions
    ypos<-sin(radial.pos[i,])*lengths[i,]
    # plot radial lines if rp.type == "r"    
    if(match("r",rptype,0))
      segments(0,0,xpos,ypos,col=linecol,lty=ltype,lwd=lwidth,...)
    if(match("p",rptype,0))
      polygon(xpos,ypos,border=linecol,col=polycol,lty=ltype,
              lwd=lwidth,...)
    if(match("s",rptype,0))
      points(xpos,ypos,pch=pointsymbols,col=pointcol,...)
    if(match("l",rptype,0))
      lines(xpos,ypos,lty=ltype,lwd=lwidth,col=linecol,...)
    if(show.centroid) {
      if(match("p",rptype,0)) {
        nvertices<-length(xpos)
        # first get the "last to first" area component
        polygonarea<-xpos[nvertices]*ypos[1] - xpos[1]*ypos[nvertices]
        for(vertex in 1:(nvertices-1))
          polygonarea<-
          polygonarea+xpos[vertex]*ypos[vertex+1]-xpos[vertex+1]*ypos[vertex]
        polygonarea<-polygonarea/2
        centroidx<-
          (xpos[nvertices]+xpos[1])*(xpos[nvertices]*ypos[1]-xpos[1]*ypos[nvertices])
        centroidy<-
          (ypos[nvertices]+ypos[1])*(xpos[nvertices]*ypos[1]-xpos[1]*ypos[nvertices])
        for(vertex in 1:(nvertices-1)) {
          centroidx<-centroidx + (xpos[vertex]+xpos[vertex+1])*
            (xpos[vertex]*ypos[vertex+1]-xpos[vertex+1]*ypos[vertex])
          centroidy<-centroidy + (ypos[vertex]+ypos[vertex+1])*
            (xpos[vertex]*ypos[vertex+1]-xpos[vertex+1]*ypos[vertex])
        }
        points(centroidx/(6*polygonarea),centroidy/(6*polygonarea),
               col=point.col[i],pch=point.symbols[i],cex=2,...)
        
      }
      else
        points(mean(xpos),mean(ypos),col=pointcol,pch=pointsymbols,
               cex=2,...)
    }
  }
  if(show.grid.labels && !add) {
    if(show.grid.labels%%2) {
      ypos<-grid.pos-radial.lim[1]
      xpos<-rep(0,length(grid.pos))
      if(show.grid.labels==1) ypos<--ypos
    }
    else {
      xpos<-grid.pos-radial.lim[1]
      ypos<-rep(0,length(grid.pos))
      if(show.grid.labels==2) xpos<--xpos
    }
    if(is.null(radial.labels)) radial.labels<-grid.pos
    if(!is.null(grid.unit))
      radial.labels[length(grid.pos)]<-
        paste(radial.labels[length(grid.pos)],grid.unit)
    if(boxed.radial)
      .boxed.labels(xpos,ypos,radial.labels,border=FALSE,
                   cex=par("cex.lab"))
    else text(xpos,ypos,radial.labels,cex=par("cex.lab"))
  }
  invisible(oldpar)
}

.radial.grid<-function(labels=NA,label.pos=NULL,radlab=FALSE,radial.lim=NULL,
                       start=0,clockwise=FALSE,label.prop=1.1,grid.pos,rad.col="gray",
                       grid.col="gray",grid.bg="transparent",show.radial.grid=TRUE,
                       start.plot=FALSE) {
  
  if(start.plot) {
    radial.span<-diff(radial.lim)
    plot(0,type="n",xlim=c(-radial.span,radial.span),
         ylim=c(-radial.span,radial.span),xlab="",ylab="",axes=FALSE)
  }
  par(xpd=TRUE)
  if(is.null(label.pos)) label.pos<-seq(0,1.8*pi,length=9)
  if(!is.null(labels)) {
    if(is.na(labels[1])) labels<-as.character(round(label.pos,2))
  }
  if(clockwise) label.pos<--label.pos
  if(start) label.pos<-label.pos+start
  # display the circumferential grid
  angles<-seq(0,1.96*pi,by=0.04* pi)
  for(i in seq(length(grid.pos),1,by=-1)) {
    xpos<-cos(angles)*(grid.pos[i]-radial.lim[1])
    ypos<-sin(angles)*(grid.pos[i]-radial.lim[1])
    polygon(xpos,ypos,border=grid.col,col=grid.bg)
  }
  maxlength<-max(grid.pos)-radial.lim[1]
  # display the radial grid
  if(show.radial.grid) {
    xpos<-cos(label.pos)*maxlength
    ypos<-sin(label.pos)*maxlength
    segments(0,0,xpos,ypos,col=rad.col)
    xpos<-cos(label.pos)*maxlength
    ypos<-sin(label.pos)*maxlength
  }
  # display the circumferential labels
  if(!is.null(labels)) {
    xpos<-cos(label.pos)*maxlength*label.prop
    ypos<-sin(label.pos)*maxlength*label.prop
    if(radlab) {
      for(label in 1:length(labels)) {
        labelsrt<-(180*label.pos[label]/pi)+180*
          (label.pos[label] > pi/2 && label.pos[label] < 3*pi/2)
        text(xpos[label],ypos[label],labels[label],
             cex=par("cex.axis"),srt=labelsrt)
      }
    }
    else
      .boxed.labels(x = xpos, y = ypos,labels,ypad=0.7,border=FALSE,cex=par("cex.axis"))
  }
  par(xpd = FALSE)
}



.boxed.labels<-function (x, y = NA, labels,
                         bg = ifelse(match(par("bg"), "transparent", 0), "white", par("bg")),
                         border = TRUE, xpad = 1.2, ypad = 1.2, 
                         srt = 0, cex = 1, adj = 0.5, xlog=FALSE, ylog=FALSE, ...) {
  
  oldpars <- par(c("cex", "xpd"))
  par(cex = cex, xpd = TRUE)
  box.adj <- adj + (xpad - 1) * cex * (0.5 - adj)
  if (srt == 90 || srt == 270) {
    bheights <- strwidth(labels)
    theights <- bheights * (1 - box.adj)
    bheights <- bheights * box.adj
    lwidths <- rwidths <- strheight(labels) * 0.5
  }
  else {
    lwidths <- strwidth(labels)
    rwidths <- lwidths * (1 - box.adj)
    lwidths <- lwidths * box.adj
    bheights <- theights <- strheight(labels) * 0.5
  }
  args <- list(x = x, y = y, labels = labels, srt = srt, adj = adj, 
               col = ifelse(colSums(col2rgb(bg) * c(1, 1.4, 0.6)) < 
                              350, "white", "black"))
  args <- modifyList(args, list(...))
  if(xlog){
    xpad<-xpad*2
    xr<-exp(log(x) - lwidths * xpad)
    xl<-exp(log(x) + lwidths * xpad)
  }
  else{
    xr<-x - lwidths * xpad
    xl<-x + lwidths * xpad
  }
  if(ylog){
    ypad<-ypad*2
    yb<-exp(log(y) - bheights * ypad)
    yt<-exp(log(y) + theights * ypad)
  }
  else{
    yb<-y - bheights * ypad
    yt<-y + theights * ypad
  }	
  rect(xr, yb, xl, yt, col = bg, border = border)
  do.call(text, args)
  par(cex = oldpars)
}