/
resample_est.R
163 lines (133 loc) · 6.61 KB
/
resample_est.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
#' Resample wave objects in a extended selection table
#'
#' \code{resample_est} changes sampling rate and bit depth of wave objects in a extended selection table.
#' @usage resample_est(X, samp.rate = 44.1, bit.depth = 16,
#' avoid.clip = TRUE, pb = FALSE, parallel = 1)
#' @param X object of class 'extended_selection_table' (see \code{\link{selection_table}}).
#' @param samp.rate Numeric vector of length 1 with the sampling rate (in kHz) for output files. Default is \code{NULL}.
#' @param bit.depth Numeric vector of length 1 with the dynamic interval (i.e. bit depth) for output files.
# #' @param sox Logical to control whether \href{https://sourceforge.net/projects/sox/}{SOX} is used internally for resampling. Sox must be installed. Default is \code{FALSE}. \href{https://sourceforge.net/projects/sox/}{SOX} is a better option if having aliasing issues after resampling.
#' @param avoid.clip Logical to control whether the volume is automatically
#' adjusted to avoid clipping high amplitude samples when resampling. Ignored if
#' '\code{sox = FALSE}. Default is \code{TRUE}.
#' @param pb Logical argument to control progress bar. Default is \code{FALSE}.
#' @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).
#' @return An extended selection table with the modified wave objects.
#' @export
#' @name resample_est
#' @details This function aims to simplify the process of homogenizing sound
#' files (sampling rate and bit depth). This is a necessary step before running
#' any further (bio)acoustic analysis. \href{https://sourceforge.net/projects/sox/}{SOX} must be installed.
#' @examples
#' \dontrun{
#' data(list = c("Phae.long1", "Phae.long2", "Phae.long3", "Phae.long4", "selec_table"))
#' writeWave(Phae.long1, file.path(tempdir(), "Phae.long1.wav"))
#' writeWave(Phae.long2, file.path(tempdir(), "Phae.long2.wav"))
#' writeWave(Phae.long3, file.path(tempdir(), "Phae.long3.wav"))
#' writeWave(Phae.long4, file.path(tempdir(), "Phae.long4.wav"))
#'
#' # create extended selection table
#' X <- selection_table(
#' X = lbh_selec_table, extended = TRUE, pb = FALSE,
#' path = tempdir()
#' )
#'
#' # resample
#' Y <- resample_est(X)
#' }
#' @family extended selection table manipulation
#' @seealso \code{\link{mp32wav}}, \code{\link{fix_wavs}}
#' @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.
#' }
#' @author Marcelo Araya-Salas (\email{marcelo.araya@@ucr.ac.cr})
#' #last modification on oct-15-2018 (MAS)
resample_est <- function(X, samp.rate = 44.1, bit.depth = 16, avoid.clip = TRUE, pb = FALSE, parallel = 1) {
# error message if bioacoustics is not installed
# if (!requireNamespace("bioacoustics",quietly = TRUE) & !sox)
# stop2("must install 'bioacoustics' to use mp32wav() when 'sox = FALSE'")
# check bit.depth
if (length(bit.depth) > 1) stop2("'bit.depth' should have a single value")
bit.depth <- as.character(bit.depth)
if (!bit.depth %in% c("1", "8", "16", "24", "32", "64", "0")) stop2('only this "bit.depth" values allowed c("1", "8", "16", "24", "32", "64", "0") \n see ?tuneR::normalize')
#### set arguments from options
# get function arguments
argms <- methods::formalArgs(resample_est)
# 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 seq_len(length(opt.argms))) {
assign(names(opt.argms)[q], opt.argms[[q]])
}
}
# 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
}
# if (!sox)
# out <- pblapply_wrblr_int(pbar = pb, X = attributes(X)$wave.objects, cl = cl, function(x)
# {
#
# if (x@samp.rate != samp.rate * 1000) {
#
# # filter first to avoid aliasing when downsampling
# if (x@samp.rate > samp.rate * 1000)
# x <- seewave::fir(wave = x , f = x@samp.rate, from = 0, to = samp.rate * 1000 / 2, bandpass = TRUE, output = "Wave")
#
# x <- warbleR::resample(wave = x, to = samp.rate * 1000)
# }
#
# # normalize
# if (bit.depth != x@bit)
# x <- tuneR::normalize(object = x, unit = bit.depth)
#
# return(x)
#
# }) else {
#
out <- pblapply_wrblr_int(pbar = pb, X = attributes(X)$wave.objects, FUN = function(x) {
# fo saving current wave
tempfile <- paste0(tempfile(), ".wav")
# for writting converted wave
tempfile2 <- paste0(tempfile(), ".wav")
suppressWarnings(tuneR::writeWave(extensible = FALSE, object = tuneR::normalize(x, unit = bit.depth), filename = tempfile))
cll <- paste0("sox '", tempfile, "' -t wavpcm ", "-b ", bit.depth, " '", tempfile2, "' rate ", samp.rate * 1000, " dither -s")
if (avoid.clip) cll <- gsub("^sox", "sox -G", cll)
# if (x@samp.rate < samp.rate * 1000) cll <- gsub("dither -s$", "resample", cll)
if (Sys.info()[1] == "Windows") cll <- gsub("'", "\"", cll)
out <- suppressWarnings(system(cll, ignore.stdout = FALSE, intern = TRUE))
x <- warbleR::read_sound_file(X = basename(tempfile2), path = tempdir())
# remove files
unlink(c(tempfile, tempfile2))
return(x)
})
# }
# replace with resampled waves
attributes(X)$wave.objects <- out
# fix attributes
attributes(X)$check.results$sample.rate <- samp.rate
attributes(X)$check.results$bits <- bit.depth
attributes(X)$check.results$n.samples <- sapply(X$sound.files, function(x) length(attributes(X)$wave.objects[[which(names(attributes(X)$wave.objects) == x)]]@left))
if (any(X$top.freq > samp.rate / 2)) {
X$top.freq[X$top.freq > samp.rate / 2] <- samp.rate / 2
warning2(x = "Some 'top.freq' values higher than nyquist frequency were set to samp.rate/2")
}
return(X)
}
##############################################################################################################
#' alternative name for \code{\link{resample_est}}
#'
#' @keywords internal
#' @details see \code{\link{resample_est}} for documentation. \code{\link{resample_est_waves}} will be deprecated in future versions.
#' @export
resample_est_waves <- resample_est