R/find_peaks_bRlo_int.R

In baRulho: Quantifying Habitat-Induced Acoustic Signal Degradation

# internal baRulho function, not to be called by users. It is a modified version of warbleR::find_peaks
# that allows to define internally if progress bar would be used (pbapply::pblapply uses pboptions to do this) 
# Find cross-correlation peaks
# 
# \code{find_peaks} find peaks in cross-correlation scores from \code{\link{cross_correlation}}
# @usage find_peaks(xc.output, parallel = 1, cutoff = 0.4, path = NULL, pb = TRUE,
# max.peak = FALSE, output = "data.frame")
# @param xc.output output of \code{\link{cross_correlation}} after setting \code{output = "list"}.
# @param parallel Numeric. Controls whether parallel computing is applied.
# It specifies the number of cores to be used. Default is 1 (i.e. no parallel computing).
# @param cutoff Numeric vector of length 1 with a value between 0 and 1 specifying the correlation cutoff for detecting peaks. Default is 0.4.
# @param path Character string containing the directory path where the sound files are located.
# If \code{NULL} (default) then the current working directory is used.
# @param pb Logical argument to control progress bar. Default is \code{TRUE}.
# @param max.peak Logical argument to control whether only the peak with the highest correlation value is returned (if TRUE; cutoff will be ignored). Default is \code{FALSE}.
# @param output Character vector of length 1 to determine if only the detected peaks are returned ('cormat') or a list ('list') containing 1) the peaks  and 2) a data frame with correlation values at each sliding step for each comparison. The list, which is also of class 'peaks.output', can be used to graphically explore detections using \code{\link{full_spectrograms}}.
# @return The function returns a data frame with time and correlation score for the
# detected peaks.
# @export
# @name find_peaks
# @details This function finds cross-correlation peaks along signals (analogous to \code{\link[monitoR]{findPeaks}}).
# @examples
# {
# # load data
# data(list = c("Phae.long4", "Phae.long2", "lbh_selec_table2", "comp_matrix"))
# 
# # save sound files
# writeWave(Phae.long4, file.path(tempdir(), "Phae.long4.wav"))
# writeWave(Phae.long2, file.path(tempdir(), "Phae.long2.wav"))
# 
# # run cross-correlation
# xc.output <- cross_correlation(X = lbh_selec_table2, output = "list",
# compare.matrix = comp_matrix, path = tempdir())
# 
# # find peaks
# pks <- find_peaks(xc.output = xc.output, path = tempdir())
# }
# @seealso \code{\link{auto_detec}}, \code{\link[monitoR]{findPeaks}}
# @author Marcelo Araya-Salas \email{marcelo.araya@@ucr.ac.cr})
# 
# @references {
# Araya-Salas, M., & Smith-Vidaurre, G. (2017). warbleR: An R package to streamline analysis of animal acoustic signals. Methods in Ecology and Evolution, 8(2), 184-191.
# 
# H. Khanna, S.L.L. Gaunt & D.A. McCallum (1997). Digital spectrographic cross-correlation: tests of sensitivity. Bioacoustics 7(3): 209-234
# }
# last modification on jan-014-2021 (MAS)
find_peaks_bRlh_int <- function(xc.output, parallel = 1, cutoff = 0.4, pb = TRUE, max.peak = FALSE, output = "data.frame") 
{
  # #### set arguments from options
  # # get function arguments
  # argms <- methods::formalArgs(find_peaks)
  # 
  # # get warbleR options
  # opt.argms <- if(!is.null(getOption("warbleR"))) getOption("warbleR") else SILLYNAME <- 0
  # 
  # # remove options not as default in call and not in function arguments
  # opt.argms <- opt.argms[!sapply(opt.argms, is.null) & names(opt.argms) %in% argms]
  # 
  # # get arguments set in the call
  # call.argms <- as.list(base::match.call())[-1]
  # 
  # # remove arguments in options that are in call
  # opt.argms <- opt.argms[!names(opt.argms) %in% names(call.argms)]
  # 
  # # set options left
  # if (length(opt.argms) > 0)
  #   for (q in 1:length(opt.argms))
  #     assign(names(opt.argms)[q], opt.argms[[q]])
  
  #check pth to working directory
  # if (is.null(pth)) pth <- getwd() else 
  #   if (!dir.exists(pth)) 
  #     stop("'pth' provided does not exist") else
  #       path <- normalizePath(path)
  
  # set clusters for windows OS and no soz
  if (Sys.info()[1] == "Windows" & parallel > 1)
    cl <- parallel::makePSOCKcluster(getOption("cl.cores", parallel)) else cl <- parallel
  
  # loop over scores of each dyad
  pks <- warbleR:::pblapply_wrblr_int(pbar = pb, X = unique(xc.output$scores$dyad), cl = cl, FUN = function(i) {
    
    # extract data for a dyad
    dat <- xc.output$scores[xc.output$scores$dyad == i, ]
    
    # check xc.output being a autodetec.output object
    if (!(is(xc.output, "xcorr.output") | is(xc.output, "xc.output"))) 
      stop("'xc.output' must be and object of class 'xcorr.output'")
    
    ## get peaks as the ones higher than previous and following scores  
    pks <- dat[c(FALSE, diff(dat$score) > 0) & c(rev(diff(rev(dat$score)) > 0), FALSE) & dat$score > cutoff, , drop = FALSE]
    
    # get the single highest peak
    if (max.peak)
      pks <- dat[which.max(dat$score), , drop = FALSE]
    
    return(pks)
  })
  
  # put results in a data frame
  peaks <- do.call(rbind, pks)
  
  # relabel rows
  if (nrow(peaks) > 0)
  {  rownames(peaks) <- 1:nrow(peaks)
  
  # remove dyad column
  peaks$dyad <- NULL
  
  #### name as in a warbleR selection table
  # remove selec info at the end
  peaks$sound.files <- substr(peaks$sound.files, start = 0, regexpr("\\-[^\\-]*$", peaks$sound.files) - 1)
  
  #### add start and end
  # add template column to selection table in xc.output
  Y <- xc.output$org.selection.table
  Y$template <- paste(Y$sound.files, Y$selec, sep = "-")
  
  # Y <- Y[Y$template %in% comp_mat[, 1], ]
  
  # add start as time - half duration of template
  peaks$start <- sapply(1:nrow(peaks), function(i){
    
    peaks$time[i] - 
      ((Y$end[Y$template == peaks$template[i]] - 
          Y$start[Y$template == peaks$template[i]])  / 2)
    
  })
  
  # add end as time + half duration of template
  peaks$end <- sapply(1:nrow(peaks), function(i){
    
    peaks$time[i] + 
      ((Y$end[Y$template == peaks$template[i]] - 
          Y$start[Y$template == peaks$template[i]]) / 2)
    
  })
  
  # add selec labels
  peaks$selec <- 1
  
  if (nrow(peaks) > 1)
    for(i in 2:nrow(peaks)) 
      if (peaks$sound.files[i] == peaks$sound.files[i - 1])
        peaks$selec[i] <- peaks$selec[i - 1] + 1
  
  # sort columns in a intuitive order
  peaks <- warbleR::sort_colms(peaks)
  
  # output results
  if (output == "data.frame") return(peaks) else{
    
    output_list <- list(
      selection.table = peaks, 
      scores = xc.output$scores,  
      cutoff = cutoff,
      call = base::match.call(),
      spectrogram = xc.output$spectrogram
      # warbleR.version = packageVersion("warbleR")
      )
    
    class(output_list) <- c("list", "find_peaks.output")
    
    return(output_list)
  }
  
  } else {
    
    # no detections    
    write(file = "", x = "no peaks above cutoff were detected")  
    
    return(NULL)  
  }
}

##############################################################################################################

# print method for class \code{xcorr.output}
#
# @param x Object of class \code{find_peaks.output}, generated by \code{\link{find_peaks}}.
# @param ...	 further arguments passed to or from other methods. Ignored when printing selection tables.
# @keywords internal
#
# @export
# 
# 
# print.find_peaks.output <- function(x, ...) {
#   
#   cat(crayon::cyan(paste("Object of class", crayon::bold("'find_peaks.output' \n"))))
#   
#   cat(crayon::silver(paste(crayon::bold("\nContains: \n"), "The output of a detection routine from the following", crayon::italic("find_peaks()"), "call: \n")))
#   
#   cll <- paste0(deparse(x$call))
#   cat(crayon::silver(crayon::italic(gsub("    ", "", cll), "\n")))
# 
#   
#   #print count of detections per sound file
#   #define columns to show
#   if (nrow(x$selection.table) > 0)
#   
#   tab <- aggregate(selec ~ sound.files, data = x$selection.table, FUN = length)  
#   names(tab)[2] <- "detections"  
#   
#   cat(crayon::silver("\n The following peaks (i.e. detections, found in the 'selection.table' list element) per sound files were found: \n"))
#   
#   kntr_tab <- knitr::kable(head(tab), escape = FALSE, digits  = 4, justify = "centre", format = "pipe")
#   
#   for(i in 1:length(kntr_tab)) cat(crayon::silver(paste0(kntr_tab[i], "\n")))
#   
#   cat(crayon::silver("\n The peaks are found in the 'selection.table' list element \n"))
#   
#   cat(crayon::silver(paste("\n Use", crayon::bold(crayon::italic("full_spectrograms()")), "to plot detections along spectrograms \n")))
# 
#   # print warbleR version
#   if (!is.null(x$warbleR.version))
#     cat(crayon::silver(paste0("\n Created by warbleR ", x$warbleR.version)), "\n") else
#       cat(crayon::silver("\n Created by warbleR < 1.1.27 \n"))
#   }