R/Methods-plot.R

In monitoR: Acoustic Template Detection in R

# For plotting templates
# Modified: 6 Sept 2015

setMethod('plot', signature(x='TemplateList', y='ANY'), 
  function(
    x,                             # Complete template list
    which.one=names(x@templates),  # If template list is provided, which template(s) should be used?
    click=FALSE,                   # Set to FALSE for no interaction
    ask=if(length(which.one)>1) TRUE else FALSE, # Set to FALSE for no pause between plots
    spec.col=gray.3(),             # Color palette for spectrogram
    on.col='#FFA50075',            # Color for on points in binary templates
    off.col='#0000FF75',           # Color for off points in binary templates
    pt.col='#FFA50075',            # Color for correlation template points
    line.col='black'               #
  ) {
  
    # Set mai and get oldask
    oldpar <- par(mai=c(1.02, 0.82, 0.82, 0.82))
    oldask <- par(ask=par('ask'))
    on.exit(par(c(oldpar, oldask)))
    
    # Template loop
    for(i in which.one) {
      template <- x@templates[[i]]
  
      # Pull out clip name
      clip.path <- template@clip.path
      file.ext <- tolower(gsub(".*\\.", "", clip.path))
      if(file.ext == 'wav') clip <- tuneR::readWave(filename=clip.path) else if(file.ext == 'mp3') clip.path <- readMP3(filename=clip) else stop('File extension must be wav or mp3, got ', file.ext)
  
      # Get time and frequency limits
      # t.lim is for cutting the clip, and needs to include samples (i.e., wave@left) that are hanging at the end when ovlp > 0
      # The next line actually should return one extra point
      t.lim <- template@first.t.bin + c(0, template@duration + template@t.step*100/(100-template@ovlp))
      frq.lim <- template@frq.lim + c(-1, 1)*template@frq.step/2
  
      wave <- cutWave(clip, from=t.lim[1], to=t.lim[2]) 
  
      # Fourier transform
      fspec <- spectro(wave=wave, wl=template@wl, ovlp=template@ovlp, wn=template@wn)
      # Filter amplitudes 
      t.bins <- fspec$time
      n.t.bins <- length(t.bins)
      which.t.bins <- 1:n.t.bins
      which.frq.bins <- which(fspec$freq >= frq.lim[1] & fspec$freq <= frq.lim[2])
      frq.bins <- fspec$freq[which.frq.bins]
      n.frq.bins <- length(frq.bins)
      amp <- fspec$amp[which.frq.bins, ]
      t.step <- t.bins[2]-t.bins[1]
      frq.step <- frq.bins[2]-frq.bins[1]
  
      # Create plot
      image(x=which.t.bins, y=which.frq.bins, t(amp), col=spec.col, xlab='Time (s)', ylab='Frequency (kHz)', las=1, useRaster=TRUE, axes=FALSE, las=1)
      t.bin.ticks <- pretty(t.bins+t.lim[1], n=6);axis(1, at=(t.bin.ticks-t.lim[1])/t.step, labels=t.bin.ticks)
      frq.bin.ticks <- pretty(frq.bins, n=6);axis(2, at=frq.bin.ticks/frq.step, labels=frq.bin.ticks, las=1)
      axis(3);axis(4, las=1);box()
      mtext(paste('Template', i), 3,line=3, cex=1.2)
   
      # Plot template points
      if(class(x) == 'binTemplateList') {
  
        pt.on <- template@pt.on
        pt.off <- template@pt.off
  
        pt.on[, 'frq'] <- pt.on[, 'frq'] - min(which.frq.bins) + 1
        pt.off[, 'frq'] <- pt.off[, 'frq'] - min(which.frq.bins) + 1
        bin.amp <- 0*amp
        bin.amp[pt.on[, c(2, 1)]] <- 1
        bin.amp[pt.off[, c(2, 1)]] <- 2
  
        image(x=which.t.bins, y=which.frq.bins, t(bin.amp), zlim=c(0, 2), col=c('transparent', on.col, off.col), add=TRUE)
  
      } else if (class(x) == 'corTemplateList') {
  
        pts <- template@pts
        pts[, 'frq'] <- pts[, 'frq'] - min(which.frq.bins) + 1
        bin.amp <- 0*amp
        bin.amp[pts[, c(2, 1)]] <- 1
  
        image(x=which.t.bins, y=which.frq.bins, t(bin.amp), zlim=c(0, 1), col=c('transparent', pt.col), add=TRUE)
  
      } else stop('Template list class not recognized.')
  
      # Start loop for identifying plot locations 
      if(click) {
        i <- 0
        click.pts <- NULL
        message('Identify plot locations with left mouse click. To exit, right click.')
        pos <- NULL
        while(!is.null(pos)|i == 0) {
          i <- i + 1
          pos <- locator(n=1)
          if(!is.null(pos)) {
            pos <- lapply(pos, round)
            abline(h=pos$y, col=line.col)
            abline(v=pos$x, col=line.col)
            text(pos$x, pos$y, i,col='red')
  
            # locator returned bin positions, so time and frequency values need to be determined from indexing
            t.pos <- t.lim[1] + t.bins[pos$x] + t.step # + t.step there because first time bin is zero. . .IS THIS A PROBLEM ELSEWHERE?
            frq.pos <- frq.bins[pos$y - min(which.frq.bins) + 1]
            amp.pos <- amp[pos$y - min(which.frq.bins) + 1, pos$x]
            click.pts <- rbind(click.pts, c(t.pos, frq.pos, amp.pos))
  
            x.mid <- mean(par()$usr[1:2])
            y.lim <- par()$usr[3:4]
  
            text(x.mid, y.lim[2]-i/20*diff(y.lim), paste(i, '.time=', signif(t.pos, 3), ',frq=', signif(frq.pos, 3), ',amp=', signif(amp.pos, 3), sep=''), cex=0.8, col=line.col)
          }
        } 
      }
      par(ask=ask)
    }

    if(click) {
      colnames(click.pts) <- c('t', 'frq', 'amp')
      invisible(click.pts)
    }

  }
)


# templateScores

setMethod('plot', signature(x='detectionList', y='ANY'), 
  function(
  x,  
  flim=c(0, 12),                 # Frequency limits for the spectrogram.
  scorelim,                     # Plot limits for scores
  which.one=names(x@templates), # Name(s) of templates to plot
  box=TRUE,                     # Set to FALSE to surpress boxes in spectrogram showing hits
  spec.col=gray.2(),            # Color palette for spectrogram
  t.each=30,                    # Time shown for each individual plot (s)
  hit.marker='lines',           # Markers for hits in score plot
  color=c('red', 'blue', 'green', 'orange', 'purple', 'pink', 'darkgreen', 'turquoise', 'royalblue', 'orchid4', 'brown', 'salmon2'), # Colors for individual templates
  legend=TRUE,                  # Set to FALSE to surpress legend
  all.peaks=FALSE,              # Set to TRUE to indicate locations of all peaks
  ask=if(dev.list() == 2) TRUE else FALSE 
  ) {

    survey <- x@survey
    t.survey <- length(survey@left)/survey@samp.rate 
    n.plots <- ceiling(t.survey/t.each)
    t.start <- 1:n.plots*t.each - t.each
    if(n.plots == 1) t.each <- t.survey
    t.end <- t.start + t.each
    t.end[t.end>t.survey] <- t.survey
    t.start[n.plots] <- t.end[n.plots] - t.each # Adjust start of last plot back so it has the same length as the others

    # Pull out spectrogram data from scores object
    # Based on first template
    amp <- x@survey.data[[1]]$amp
    t.bins <- x@survey.data[[1]]$t.bins
    frq.bins <- x@survey.data[[1]]$frq.bins
 
    # Sort out colors for lines and boxes
    names.t <- names(x@templates)
    n.templates <- length(names.t)
    color <- c(rep(color, n.templates %/% length(color)), color[1:n.templates%%length(color)])
    names(color) <- names.t

    # Get scorelim
    if(missing(scorelim)) {
      upr <- 0
      for(i in seq(length(x@scores))) {
        upr <- max(upr, x@scores[[i]]$score)
      }
      scorelim <- c(0, upr)
    }

    oldpar <- par(mar=c(1, 4,1, 1), oma=c(6, 0,0, 0), mfrow=c(2, 1))
    oldask <- par(ask=par('ask'))
    on.exit(par(c(oldpar, oldask)))

    # Loop through time windows, plotting a spectrogram for each time
    for(i in 1:length(t.start)) {

      message(paste(t.start[i], 'to', t.end[i], 'seconds'))
    
      times <- t.bins[t.bins>=t.start[i] & t.bins<=t.end[i]]
      amp.clip <- amp[, t.bins %in% times]
      image(x=times, y=frq.bins, t(amp.clip), ylim=flim, col=spec.col, xlab='', ylab='Frequency (kHz)', xaxt='n', las=1)
 
      # Loop through templates and add boxes around detections
      for(j in which.one) {
        template <- x@templates[[j]]
        if(all.peaks) pks <- x@peaks[[j]] else pks <- x@detections[[j]]
        pks.clip <- pks[pks$time + template@duration >= t.start[i] & pks$time - template@duration <= t.end[i], ]

        if(box & nrow(pks.clip)>0) {
          for(k in 1:nrow(pks.clip)) { 
            xleft <- pks.clip$time[k] - template@duration/2
            xright <- pks.clip$time[k] + template@duration/2
            ylwr <- template@frq.lim[1]
            yupr <- template@frq.lim[2]
            polygon(x=c(xleft, xleft, xright, xright), y=c(ylwr, yupr, yupr, ylwr), border=color[j], lwd=1)
          }
        }
      }

      # Make plot of scores. Can't sort out xlab for some reason.
      plot(NULL, xlim=c(t.start[i], t.end[i]), ylim=scorelim, xlab='', ylab='Score', type='n', xaxs='i', las=1, mgp=c(3, 1,0))
      mtext("Time (s or min:sec)", 1,2.5, outer=TRUE)

      # Add x axis as mm:ss
      xaxp.sec <- par('xaxp')
      labs.sec <- seq(xaxp.sec[1], xaxp.sec[2], length.out=xaxp.sec[3]+1)
      labs.mmss <- paste(sprintf('%02d', labs.sec%/%60), ':', sprintf('%02d', labs.sec%%60), sep='')
      axis(1, at=labs.sec, labels=labs.mmss, mgp=c(3, 1.9, 0))

      if(legend) legend('topright', which.one, lty=1, col=color[which.one], cex=0.7)

      # Loop through templates 
      for(j in which.one) {
        template <- x@templates[[j]]
        score <- x@scores[[j]]         # score output from sccDetect. The correlation coefficients within which hits were found.
        if(all.peaks) pks <- x@peaks[[j]] else pks <- x@detections[[j]]
        cutoff <- template@score.cutoff      # If given, will plot a horizontal line at the correlation coefficient cutoff.

        score.clip <- score[score$time>=t.start[i] & score$time<=t.end[i], ]
        pks.clip <- pks[pks$time + template@duration >= t.start[i] & pks$time - template@duration <= t.end[i], ]

        lines(score.clip$time, score.clip$score, col=color[j])
        if(hit.marker == 'points') points(pks.clip$time, pks.clip$score, col=color[j]) else
          if(hit.marker == 'lines') abline(v=pks.clip$time, col=color[j]) 
        if(is.vector(cutoff)) abline(h=cutoff, lty=2, col=color[j])
      }
      par(ask=ask)
    }
  
  }
)