R/writeEventClips.R

In PAMpal: Load and Process Passive Acoustic Data

#' @title Create Wav Clips of Data
#'
#' @description Creates audio clips containing sounds from events or detections
#'
#' @details \code{parseEventClipName} parses the file names created to pull out
#'   event names or file start times
#'
#' @param x \linkS4class{AcousticStudy} object containing data to make wav clips for
#' @param buffer amount before and after each event to also include in the clip, in seconds.
#'   Can either be a vector of length two specifying how much to buffer before and after
#'   (first number should be negative), or a single value if the buffer amount should be identical.
#' @param outDir directory to write clips to, defaults to current directory
#' @param mode either \code{'event'} or \code{'detection'} specifying whether to create
#'   wav clips of entire events or individual detections
#' @param channel channel(s) of clips to write
#' @param filter filter to apply to wav clips before writing, values in kHz. A value of \code{0}
#'   applies no filter. A single value applies a highpass filter at that value. A vector of two
#'   values applies a lowpass filter if the first number is \code{0}, or a bandpass filter if
#'   both are non-zero.
#' @param useSample logical flag to use startSample information in binaries instead of UTC
#'   time for start of detections. This can be slightly more accurate (~1ms) but will take
#'   longer
#' @param fixLength logical flag to fix the output clip length to a constant value. If
#'   \code{TRUE}, then output clip length is entirely determined by the buffer value, as
#'   if the detection or event had zero length. E.g. \code{buffer=c(-2,1)} will produce clips
#'   3 seconds long, starting 2 seconds before the detection/event start time.
#' @param rerun logical flag to rerun for existing wav clips
#' @param progress logical flag to show progress bar
#' @param verbose logical flag to show summary messages
#'
#' @return A vector of file names for the wav clips that were successfully
#'   created, any that were not able to be written will be \code{NA}. Note
#'   that currently this can only write clips with up to 2 channels. File names
#'   will be formatted as
#'   [Event or Detection]_[Id]CH[ChannelNumber(s)]_[YYYYMMDD]_[HHMMSS]_[mmm].wav
#'   The last numbers are the start time of the file in UTC, accurate to milliseconds.
#'   The Id is either the event ID or the detection UID.
#'
#' @examples
#'
#' data(exStudy)
#' recs <- system.file('extdata', 'Recordings', package='PAMpal')
#' exStudy <- addRecordings(exStudy, folder=recs, log=FALSE, progress=FALSE)
#' \dontrun{
#' # not running so that no wav clips are written to disk
#' wavs <- writeEventClips(exStudy, outDir='WavFolder', mode='event')
#' }
#'
#' @author Taiki Sakai \email{taiki.sakai@@noaa.gov}
#'
#' @importFrom dplyr bind_rows arrange group_by summarise ungroup
#' @importFrom tuneR readWave writeWave MCnames bind
#'
#' @export
#'
writeEventClips <- function(x, buffer = c(0, 0.1), outDir='.', mode=c('event', 'detection'),
                            channel = 1, filter=0, useSample=FALSE, progress=TRUE, verbose=TRUE,
                            rerun=TRUE,
                            fixLength=FALSE) {
    if(!dir.exists(outDir)) dir.create(outDir)
    if(isFALSE(rerun)) {
        wavFiles <- list.files(outDir, pattern='wav$')
        switch(match.arg(mode),
               'event' = {
                   wavEvents <- parseEventClipName(wavFiles, part='event')
                   x <- filter(x, !.data$eventId %in% wavEvents)
               },
               'detection' = {
                   wavIds <- parseEventClipName(wavFiles, part='UID')
                   x <- filter(x, !.data$UID %in% wavIds)
               }
        )
        if(nDetections(x) == 0) {
            message('Appears that all wav files exist, and rerun=FALSE. No new files created')
            return(character(0))
        }
    }
    if(length(channel) > 2) {  #### WAV CLIP SPECIFIC
        message('R can only write wav files with 2 or less channels, channels will be split',
                ' across multiple files.')
        allFiles <- character(0)
        for(i in 1:(ceiling(length(channel)/2))) {
            ix <- (i-1)*2 +1
            if((ix+1) <= length(channel)) {
                thisChan <- channel[ix:(ix+1)]
            } else {
                thisChan <- channel[ix]
            }
            allFiles <- c(allFiles, writeEventClips(x, buffer=buffer, outDir=outDir, mode=mode, filter=filter,
                                                    channel = thisChan, useSample=useSample,progress=progress,
                                                    verbose=verbose, fixLength=fixLength))
        }
        return(allFiles)
    }
    getClipData(x, buffer=buffer, mode=mode, channel=channel, useSample=useSample,
                progress=progress, verbose=verbose, FUN=writeOneClip, outDir=outDir,
                filter=filter, fixLength=fixLength, toWaveMC=FALSE)
}

# globalVariables(c('UID', 'eventId'))

#' @importFrom audio save.wave
#' 
writeOneClip <- function(wav, name, time, channel, mode, outDir='.', filter) {
    fileName <- paste0(oneUpper(mode), '_', name, 'CH', paste0(channel, collapse='-'))
    fileName <- paste0(fileName, '_',psxToChar(time[1]))
    fileName <- paste0(gsub('\\.wav$', '', fileName), '.wav')
    # timeRange[1] is actual start time in posix
    fileName <- file.path(outDir, fileName)
    if(length(filter) == 1) {
        filterFrom <- filter * 1e3
        filterTo <- NULL
    } else {
        filterFrom <- filter[1] *1e3
        filterTo <- filter[2] * 1e3
    }
    if(filterFrom == 0) {
        filterFrom <- NULL
    }
    if(!is.null(filterFrom) ||
       !is.null(filterTo)) {
        # for(i in 1:ncol(wav@.Data)) {
        #     wav@.Data[, i] <- round(seewave::bwfilter(wav@.Data[, i], f=wav@samp.rate, from=filterFrom, to=filterTo)[, 1], 0)
        # }
        if(is.null(dim(wav))) {
            wav <- seewave::bwfilter(wav, f=wav$rate, from=filterFrom, to=filterTo)[, 1]
        } else {
            for(i in 1:nrow(wav)) {
                wav[i,] <- seewave::bwfilter(wav[i,], f=wav$rate, from=filterFrom, to=filterTo)[, 1]
            }
        }
    }
    # writeWave(wav, fileName, extensible = FALSE)
    maxTries <- 3
    for(i in seq_len(maxTries)) {
        tryWrite <- try(save.wave(wav, fileName), silent=TRUE)
        if(is.null(tryWrite) ||
           !inherits(tryWrite, 'try-error')) {
            break
        }
    }
    if(inherits(tryWrite, 'try-error')) {
        warning('Problem writing file ', basename(fileName))
    }
    fileName
}



oneUpper <- function(x) {
    paste0(toupper(substr(x, 1, 1)),
           tolower(substr(x, 2, nchar(x))))
}

psxToChar <- function(x) {
    psFloor <- format(as.POSIXct(
        floor(as.numeric(x)), origin='1970-01-01 00:00:00', tz='UTC'),
        format='%Y-%m-%d %H:%M:%S'
    )
    psMilli <- round(as.numeric(x)-floor(as.numeric(x)), 3)
    psMilli <- sprintf('%.3f',psMilli)
    psMilli <- substr(psMilli, 3, 5)
    psFloor <- gsub('-| |:', '', psFloor)
    paste0(substr(psFloor, 1, 8), '_',
           substr(psFloor, 9, 14), '_',
           gsub('^0\\.', '', psMilli))
}

#' @rdname writeEventClips
#'
#' @param file file name to parse
#' @param part part of file name to return
#'
#' @export
#'
parseEventClipName <- function(file, part=c('event', 'time', 'UID', 'channel', 'UTC')) {
    if(length(file) > 1) {
        return(sapply(file, function(x) {
            parseEventClipName(x, part=part)
        }, USE.NAMES=FALSE))
    }
    file <- basename(file)
    pattern <- '(Event|Detection)_(.*)(CH[0-9\\-]*)_([0-9]{14}_[0-9]{3}|[0-9]{8}_[0-9]{6}_[0-9]{3})\\.wav$'
    switch(match.arg(part),
           'event' = {
               result <- gsub(pattern, '\\2', file)
               result <- strsplit(result, '\\.')[[1]]
               result <- paste0(result[1], '.', result[2])
               result
           },
           'UID' = {
               if(gsub(pattern, '\\1', file) == 'Event') {
                   return(NA)
               }
               result <- gsub(pattern, '\\2', file)
               result <- strsplit(result, '\\.')[[1]][3]
               result
           },
           'channel' = {
               result <- gsub(pattern, '\\3', file)
               result <- gsub('CH', '', result)
               result <- gsub('-', ',', result)
               result
           },
           'time' = {
               result <- gsub(pattern, '\\4', file)
               milli <- gsub('(.*)_([0-9]{3})$', '\\2', result)
               result <- gsub('(.*)_([0-9]{3})$', '\\1', result)
               result <- gsub('_', '', result)
               result <- as.POSIXct(result, format='%Y%m%d%H%M%S', tz='UTC')
               result <- result + as.numeric(milli)/1e3
               result
           },
           'UTC' = {
               result <- gsub(pattern, '\\4', file)
               milli <- gsub('(.*)_([0-9]{3})$', '\\2', result)
               result <- gsub('(.*)_([0-9]{3})$', '\\1', result)
               result <- gsub('_', '', result)
               result <- as.POSIXct(result, format='%Y%m%d%H%M%S', tz='UTC')
               result <- result + as.numeric(milli)/1e3
               result
           }
    )
}