R/spectrogram_contour.R

In ThierryO/rhinolophus: Identify Bats from Ultrasound Recordings

#' Calculate contour polygons from a spectrogram
#' @param spectrogram A spectrogram as generated by
#'    \code{\link{wav2spectrogram}}
#' @param contour.level A vector of contour levels. If one number it is used as
#'    the step size in the vector.
#' @importFrom raster raster rasterToContour
#' @importFrom sp coordinates Polygon Polygons SpatialPolygons
#'    SpatialPolygonsDataFrame
#' @importFrom assertthat assert_that
#' @export
#' @examples
#'  wav <- read_wav(
#'    system.file("demo_wav/leislers.wav", package = "rhinolophus")
#'  )
#'  spectrogram <- wav2spectrogram(wav)
#'  spectrogram_contour(spectrogram)
spectrogram_contour <- function(spectrogram, contour.level = NULL){
  assert_that(inherits(spectrogram, "specgram"))

  if (missing(contour.level)) {
    contour.level <- seq(0, ceiling(max(spectrogram$S)), by = 1)
  } else {
    assert_that(is.numeric(contour.level))

    if (length(contour.level) == 1) {
      assert_that(contour.level > 0)

      contour.level <- seq(
        0,
        contour.level * (max(spectrogram$S) %/% contour.level),
        by = contour.level
      )
    }
  }
  spectrogram.raster <- raster(
    spectrogram$S[rev(seq_len(nrow(spectrogram$S))), ],
    xmn = min(spectrogram$t) * 1000,
    xmx = max(spectrogram$t) * 1000,
    ymn = min(spectrogram$f) / 1000,
    ymx = max(spectrogram$f) / 1000
  )
  names(spectrogram.raster) <- "dB"

  contour.line <- rasterToContour(spectrogram.raster, levels = contour.level)
  contour.closed <- lapply(
    coordinates(contour.line),
    function(x){
      sapply(
        x,
        function(y){
          identical(y[1, ], y[nrow(y), ])
        }
      )
    }
  )
  contour.line$level <- as.numeric(levels(contour.line$level))[
    contour.line$level
  ]
  contour.poly <- lapply(seq_along(contour.line), function(i){
    closed.lines <- coordinates(contour.line)[[i]][contour.closed[[i]]]
    if (length(closed.lines) == 0) {
      NULL
    } else {
      polygons <- lapply(seq_along(closed.lines), function(j){
        polygon <- Polygon(closed.lines[[j]])
        Polygons(list(polygon), ID = j + i * 1e6)
      })
      polygons <- SpatialPolygons(polygons)
      dataset <- data.frame(
        ID = as.character(seq_along(closed.lines) + i * 1e6),
        level = contour.line$level[i]
      )
      rownames(dataset) <- seq_along(closed.lines) + i * 1e6
      SpatialPolygonsDataFrame(Sr = polygons, data = dataset)
    }
  })
  contour.poly <- contour.poly[!sapply(contour.poly, is.null)]
  contour.poly <- do.call(rbind, contour.poly)
  return(contour.poly)
}