# Modified: 6 Sept 2015
showPeaks <-
function(
detection.obj, # Complete output from corMatch or binMatch
which.one = names(detection.obj@templates)[1], # Name or position of list elements that should be used
fd.rat = 4, # Plot frame to template duration frame ratio. Used only if frame is not specified.
frame = fd.rat*detection.obj@templates[[which.one]]@duration, # Length of time to be plotted.
id = 1:nrow(pks), # The row number or name of hits or peaks (within pks) that are to be plotted.
t.lim, # Instead of id numbers, give time limits
flim = c(0, 20), # Frequency limits for the spectrogram.
point = TRUE, # Use an arrow to identify the peak center.
ask = if(verify) FALSE else TRUE, # If TRUE, pauses between plots.
scorelim = NULL, # Plot limits for scores
verify = FALSE, # Set to true for verification
what = 'detections', # 'detections' for just detections, 'peaks' for all peaks
box = TRUE, # Set to FALSE to suppress box in spectrogram or "template"
player = 'play', # Command to call up external wave player, e.g., 'wv_player.exe' (Windows) or 'play' (SoX in Linux)
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
) {
# Check arguments
if(missing(detection.obj)) stop('Required argument detection.obj missing')
# ask par
oldask <- par(ask = par('ask'))
on.exit(par(oldask))
# Pull out data for plots
template <- detection.obj@templates[[which.one]]
pks <- slot(detection.obj, what)[[which.one]]
survey <- detection.obj@survey
score <- detection.obj@scores[[which.one]]
# Pull out spectrogram data from score.obj object
amp <- detection.obj@survey.data[[which.one]]$amp
t.bins <- detection.obj@survey.data[[which.one]]$t.bins
frq.bins <- detection.obj@survey.data[[which.one]]$frq.bins
which.frq.bins <- which(frq.bins >= flim[1] & frq.bins <= flim[2])
frq.bins <- frq.bins[which.frq.bins]
amp <- amp[which.frq.bins, ]
# Get score limits for plot
if(is.null(scorelim)) scorelim <- c(0, max(pks$score))
# For verification
if(verify) verC <- NULL
# Length of survey
dur.survey <- length(survey@left)/survey@samp.rate
# If t.lim is given, use it to get ids
if(!missing(t.lim)) id <- which(pks$time>= min(t.lim) & pks$time<= max(t.lim))
# Exit if there are no hits to show
if(length(id) == 2) if(all(id[1] == 1, id[2] == 0)) stop('No peaks selected.')
# THERE IS A FUNCTION NAMED ID, SHOULD CHANGE NAME HERE
# Loop through all peaks requested
i <- min(id)
while(i<= max(id)) {
x <- 'x'
t.start <- max(pks$time[i] - frame/2, 0)
t.end <- min(pks$time[i] + frame/2, dur.survey)
survey.clip <- cutWave(wave = survey, from = t.start, to = t.end)
par(mfrow = c(2, 1), mar = c(1, 4,4, 1))
score.clip <- score[score[, 'time']>= t.start & score[, 'time']<= t.end, ]
# Make spectrogram
times <- t.bins[t.bins>= t.start & t.bins<= t.end]
amp.clip <- amp[, t.bins %in% times]
image(x = times, y = frq.bins, t(amp.clip), col = spec.col, xlab = '', ylab = 'Frequency (kHz)', xaxt = 'n', las = 1, main = paste(if(what == "detections") "Detection" else "Peak", i))
if(box == TRUE & nrow(pks)>0) {
xleft <- pks$time[i]-template@duration/2
xright <- pks$time[i]+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 = 'blue')
} else if(tolower(box) == 'template' & nrow(pks)>0) {
xleft <- pks$time[i]-template@duration/2
ylwr <- template@frq.lim[1]
# Plot template points
if(class(template) == 'binTemplate') {
pt.on <- template@pt.on
pt.off <- template@pt.off
pt.on[, 't'] <- pt.on[, 't'] + ((xleft-min(times))/template@t.step)
pt.off[, 't'] <- pt.off[, 't'] + ((xleft-min(times))/template@t.step)
pt.on[, 'frq'] <- pt.on[, 'frq'] + ylwr - 1
pt.off[, 'frq'] <- pt.off[, 'frq'] + ylwr - 1
bin.amp <- 0*amp.clip
bin.amp[pt.on[, c(2, 1)]] <- 1
bin.amp[pt.off[, c(2, 1)]] <- 2
image(x = times, y = frq.bins, t(bin.amp), zlim = c(0, 2), col = c('transparent', on.col, off.col), add = TRUE)
} else if (class(template) == 'corTemplate') {
pts <- template@pts
pts[, 't'] <- pts[, 't'] + ((xleft-min(times))/template@t.step)
pts[, 'frq'] <- pts[, 'frq'] + ylwr - 1
bin.amp <- 0*amp.clip
bin.amp[pts[, c(2, 1)]] <- 1
image(x = times, 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: ', class(template))
}
par(mar = c(4, 4,1, 1))
plot(score.clip$time, score.clip$score, xlim = c(t.start, t.end), ylim = scorelim, xlab = 'Time (s)', ylab = 'Score', type = 'l', xaxs = 'i', las = 1)
if(point) {
t <- pks$time[pks$time>= t.start & pks$time<= t.end]
score.center <- pks$score[pks$time>= t.start & pks$time<= t.end]
points(t, score.center, col = 'black')
t <- pks$time[i]
score.center <- score.clip$score[score.clip$time == pks$time[i]]
score.center <- pks$score[i]
points(t, score.center, pch = 21, col = 'black', bg = 'red')
text(x = t, y = score.center, labels = round(score.center, 3), pos = 3, offset = 1)
}
abline(h = template@score.cutoff, lty = 2)
if(verify) {
while(length(x) == 0 || !x %in% c('y', 'n', 'r', NA)) {
cat(paste0('\n', i,'. True detection?\n Enter y for yes, n for no, NA for NA, p to play, r to rewind, or q to exit: '))
#x <- tolower(scan(n = 1, what = 'character', quiet = TRUE))
x <- tolower(readLines(n = 1)[1])
if(length(x) == 0) {
cat('\nYou didn\'t enter a response.\n')
next
}
if(!is.na(x) && x == 'na') x <- NA
if(is.na(x)) {
cat('NA\n')
break
}
cat(switch(x, n = FALSE, y = TRUE, p = 'Playing clip', r = 'Previous', q = 'Exiting', 'Value not recognized. Enter y, n, NA, p, r, or q.'), '\n')
if(!x %in% c('y', 'n', 'p', 'r', 'q')) next
if(x == 'q') return()
if(x == 'p') {
tuneR::writeWave(object = survey.clip, filename = tempname <- tempfile(fileext = '.wav'))
# Variation on next line may be needed if player is slow
#Sys.sleep(2)
cat("Shell command:", paste(player, tempname), '\n')
if(tolower(Sys.info()['sysname']) == 'windows') shell(cmd = paste(player, tempname), wait = FALSE)
else system(command = paste(player, tempname), wait = FALSE)
# tuneR::writeWave(object = survey.clip, filename = tempname <- paste0('temp', Sys.time(), '.wav'))
# cat("Shell command:", paste0(player, " \"", tempname, "\""), '\n')
# system(command = paste0(player, " \"", tempname, "\""), wait = FALSE)
prev.line <- 0
for(j in seq(t.start, t.end, length.out = 20)) {
t1 <- Sys.time()
abline(v = prev.line, col = 'lightgray', lwd = 3)
abline(v = j, col = 'black', lwd = 2)
prev.line <- j
delta.t <- Sys.time()-t1
Sys.sleep(max(0, (t.end-t.start)/19 - as.numeric(delta.t)))
}
# Remove wav file
file.remove(tempname)
}
}
if(is.na(x) || x != 'r') verC[i] <- x
}
par(ask = ask)
if(!is.na(x) && x == 'r') i <- i-1 else i <- i+1
if(i<1) i <- 1
}
cat("\n")
if(verify) {
slot(detection.obj, what)[[which.one]]$true <- NA
slot(detection.obj, what)[[which.one]]$true[id] <- verC == 'y'
return(detection.obj)
}
return(invisible(NULL))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.