Nothing
R/smoothContours.R
In soundgen: Sound Synthesis and Acoustic Analysis
Defines functions
reformatAnchors
getDiscreteContour
splitContour
drawContour
getSmoothContour
Documented in
drawContour
getDiscreteContour
getSmoothContour
reformatAnchors
splitContour
# Functions for generating and modifying smooth contours from a few anchors
#' Smooth contour from anchors
#'
#' Returns a smooth contour based on an arbitrary number of anchors. Used by
#' \code{\link{soundgen}} for generating intonation contour, mouth opening, etc.
#' This function is mostly intended to be used internally by soundgen, more
#' precisely to construct (upsample) smooth curves from a number of anchors. For
#' general upsampling or downsampling of audio, use \code{\link{resample}}. Note
#' that pitch contours are treated as a special case: values are log-transformed
#' prior to smoothing, so that with 2 anchors we get a linear transition on a
#' log scale (as if we were operating with musical notes rather than frequencies
#' in Hz). Pitch plots have two Y axes: one showing Hz and the other showing
#' musical notation.
#' @param anchors a numeric vector of values or a list/dataframe with one column
#' (value) or two columns (time and value). \code{achors$time} can be in ms
#' (with len=NULL) or in arbitrary units, eg 0 to 1 (with duration determined
#' by len, which must then be provided in ms). So anchors$time is assumed to
#' be in ms if len=NULL and relative if len is specified. \code{anchors$value}
#' can be on any scale.
#' @param len the required length of the output contour. If NULL, it will be
#' calculated based on the maximum time value (in ms) and \code{samplingRate}
#' @param thisIsPitch (boolean) is this a pitch contour? If true, log-transforms
#' before smoothing and plots in both Hz and musical notation
#' @param normalizeTime if TRUE, normalizes anchors$time values to range from 0 to 1
#' @param interpol method of interpolation between anchors: "approx" = linear
#' with \code{\link{approx}}, "spline" = cubic splines with
#' \code{\link{spline}}, "loess" = local polynomial regression with
#' \code{\link{loess}}
#' @param loessSpan controls the amount of smoothing when interpolating between
#' anchors with \code{\link[stats]{loess}}, so only has an effect if interpol
#' = 'loess' (1 = strong, 0.5 = weak smoothing)
#' @param discontThres if two anchors are closer in time than
#' \code{discontThres} (on a 0-1 scale, ie specified as proportion of total
#' length), the contour is broken into segments with a linear transition
#' between these segments
#' @param jumpThres if anchors are closer than \code{jumpThres}, a new section
#' starts with no transition at all (e.g. for adding pitch jumps)
#' @param valueFloor,valueCeiling lowser/upper bounds for the contour
#' @param plot (boolean) produce a plot?
#' @param samplingRate sampling rate used to convert time values to points (Hz)
#' @param voiced,contourLabel graphical pars for plotting breathing contours
#' (see examples below)
#' @param NA_to_zero if TRUE, all NAs are replaced with zero
#' @param xlim,ylim plotting options
#' @param ... other plotting options passed to \code{plot()}
#' @export
#' @return Returns a numeric vector of length \code{len}.
#' @examples
#' # long format: anchors are a dataframe
#' a = getSmoothContour(anchors = data.frame(
#' time = c(50, 137, 300), value = c(0.03, 0.78, 0.5)),
#' normalizeTime = FALSE,
#' voiced = 200, valueFloor = 0, plot = TRUE, main = '',
#' samplingRate = 16000) # breathing
#'
#' # short format: anchors are a vector (equal time steps assumed)
#' a = getSmoothContour(anchors = c(350, 800, 600),
#' len = 5500, thisIsPitch = TRUE, plot = TRUE,
#' samplingRate = 3500) # pitch
#'
#' # a single anchor gives constant value
#' a = getSmoothContour(anchors = 800,
#' len = 500, thisIsPitch = TRUE, plot = TRUE, samplingRate = 500)
#'
#' # two pitch anchors give loglinear F0 change
#' a = getSmoothContour(anchors = c(220, 440),
#' len = 500, thisIsPitch = TRUE, plot = TRUE, samplingRate = 500)
#'
#' ## Two closely spaced anchors produce a pitch jump
#' # one loess for the entire contour
#' a1 = getSmoothContour(anchors = list(time = c(0, .15, .2, .7, 1),
#' value = c(360, 116, 550, 700, 610)), len = 500, thisIsPitch = TRUE,
#' plot = TRUE, samplingRate = 500)
#' # two segments with a linear transition
#' a2 = getSmoothContour(anchors = list(time = c(0, .15, .17, .7, 1),
#' value = c(360, 116, 550, 700, 610)), len = 500, thisIsPitch = TRUE,
#' plot = TRUE, samplingRate = 500)
#' # two segments with an abrupt jump
#' a3 = getSmoothContour(anchors = list(time = c(0, .15, .155, .7, 1),
#' value = c(360, 116, 550, 700, 610)), len = 500, thisIsPitch = TRUE,
#' plot = TRUE, samplingRate = 500)
#' # compare:
#' plot(a2)
#' plot(a3) # NB: the segment before the jump is upsampled to compensate
#'
#' ## Control the amount of smoothing
#' getSmoothContour(c(1, 3, 9, 10, 9, 9, 2), len = 100, plot = TRUE,
#' loessSpan = NULL) # default amount of smoothing (depends on dur)
#' getSmoothContour(c(1, 3, 9, 10, 9, 9, 2), len = 100, plot = TRUE,
#' loessSpan = .85) # more smoothing than default
#' getSmoothContour(c(1, 3, 9, 10, 9, 9, 2), len = 100, plot = TRUE,
#' loessSpan = .5) # less smoothing
#' getSmoothContour(c(1, 3, 9, 10, 9, 9, 2), len = 100, plot = TRUE,
#' interpol = 'approx') # linear interpolation (no smoothing)
#'
#' ## Upsample preserving leading and trailing NAs
#' anchors = data.frame(time = c(1, 4, 5, 7, 10, 20, 23, 25, 30),
#' value = c(NA, NA, 10, 15, 12, NA, 17, 15, NA))
#' plot(anchors, type = 'b')
#' anchors_ups = getSmoothContour(
#' anchors, len = 200,
#' interpol = 'approx', # only approx can propagate NAs
#' NA_to_zero = FALSE, # preserve NAs
#' discontThres = 0) # don't break into sub-contours
#' plot(anchors_ups, type = 'b')
getSmoothContour = function(
anchors = data.frame(time = c(0, 1), value = c(0, 1)),
len = NULL,
thisIsPitch = FALSE,
normalizeTime = TRUE,
interpol = c('approx', 'spline', 'loess')[3],
loessSpan = NULL,
discontThres = .05,
jumpThres = .01,
valueFloor = NULL,
valueCeiling = NULL,
plot = FALSE,
xlim = NULL,
ylim = NULL,
samplingRate = 16000,
voiced = NULL,
contourLabel = NULL,
NA_to_zero = TRUE,
...) {
my_args = match.call()
if (is.null(my_args$main)) {
if (thisIsPitch)
main = 'Pitch contour'
else
main = ''
}
# if (is.null(my_args$main)) {
anchors = reformatAnchors(anchors, normalizeTime = normalizeTime)
if (!is.null(len) && len == 1) return(anchors$value[1])
if (is.list(anchors)) {
if (nrow(anchors) > 10 & nrow(anchors) < 50 & interpol == 'loess') {
interpol = 'spline'
# warning('More than 10 anchors; changing interpolation method from loess to spline')
} else if (nrow(anchors) > 50) {
interpol = 'approx'
}
} else {
stop('Invalid format of the "anchors" argument')
}
if (!is.null(valueFloor)) {
anchors$value[anchors$value < valueFloor] = valueFloor
}
if (!is.null(valueCeiling)) {
anchors$value[anchors$value > valueCeiling] = valueCeiling
}
if (thisIsPitch) {
anchors$value = HzToSemitones(anchors$value)
if (!is.null(valueFloor))
valueFloor = HzToSemitones(valueFloor)
if (!is.null(valueCeiling))
valueCeiling = HzToSemitones(valueCeiling)
}
if (is.null(len)) {
# if len is null, we expect that anchors$time encoded
# the desired duration, in ms
duration_ms = max(anchors$time) - min(anchors$time)
len = floor(duration_ms * samplingRate / 1000)
} else {
anchors$time = anchors$time - min(anchors$time)
anchors$time = anchors$time / max(anchors$time) # strictly 0 to 1
duration_ms = len / samplingRate * 1000
}
if (!is.numeric(duration_ms) | !is.numeric(len)) {
return(NA)
} else if (duration_ms == 0 | len == 0) {
return(NA)
}
if (NA_to_zero) anchors$value[is.na(anchors$value)] = 0
# get smooth contours
nr = nrow(anchors)
if (nr == len) {
# nothing to do
smoothContour = anchors$value
} else if (nr > len) {
# downsample
smoothContour = suppressWarnings(.resample(list(sound = anchors$value),
mult = len / nr))
} else if (discontThres <= 0 | nr < 3) {
# upsample in one go
smoothContour = drawContour(len = len,
anchors = anchors,
interpol = interpol,
loessSpan = loessSpan,
valueFloor = valueFloor,
duration_ms = duration_ms)
} else {
# some anchors might be too close, so we split the contour into segments
# to avoid weird behavior of loess etc
sections = splitContour(anchors = anchors,
discontThres = discontThres,
jumpThres = jumpThres)
smoothContour = vector()
for (i in 1:nrow(sections)) {
segm_len = round((anchors$time[sections$end[i]] -
anchors$time[sections$start[i]]) /
diff(range(anchors$time)) * len)
cont = drawContour(len = segm_len,
anchors = anchors[sections$start[i]:sections$end[i], ],
interpol = interpol,
loessSpan = loessSpan,
valueFloor = valueFloor,
duration_ms = duration_ms)
transition = vector()
if (i < nrow(sections)) {
trans_len = round((anchors$time[sections$start[i + 1]] -
anchors$time[sections$end[i]]) /
diff(range(anchors$time)) * len)
if (sections$jump[i] & length(cont) > 0) {
# upsample the segment before the jump to make up for skipped transition
cont = approx(cont, n = length(cont) + trans_len)$y
} else {
# make a linear transition preserving spacing between anchors
transition = seq(anchors$value[sections$end[i]],
anchors$value[sections$start[i + 1]],
length.out = trans_len)
}
}
smoothContour = c(smoothContour, cont, transition)
}
if (length(smoothContour) != len) {
smoothContour = approx(smoothContour, n = len)$y
}
}
# plot(smoothContour, type='p')
if (plot) {
idx = seq(1, len, length.out = min(len, 100))
op = par("mar") # save user's original margin settings
if (len > 100) {
# for plotting, shorten smoothContour to max 100 points
# to reduce processing load
smoothContour_downsampled = smoothContour[idx]
} else {
smoothContour_downsampled = smoothContour
}
# plot(smoothContour_downsampled)
# presuming that len was specified and anchors$time are on a
# relative scale, we transform to ms for plotting
if (!max(anchors$time) > 1) {
anchors$time = anchors$time * duration_ms
time = seq(0, len, length.out = len)
x = time[idx] / samplingRate * 1000
} else { # time is already in ms
time = seq(anchors$time[1], anchors$time[nrow(anchors)], length.out = len)
x = time[idx]
}
if (thisIsPitch) {
# pitch - log-transformed
if (!is.numeric(ylim)) {
ylim = c(
min(smoothContour_downsampled) / 1.1, # can't be negative
max(smoothContour_downsampled) * 1.1
)
} else if (min(smoothContour_downsampled) < HzToSemitones(ylim[1])) {
ylim[1] = min(smoothContour_downsampled) / 1.1
} else if (max(smoothContour_downsampled) > HzToSemitones(ylim[2])) {
ylim[2] = max(smoothContour_downsampled) * 1.1
} else {
ylim = HzToSemitones(ylim)
}
lbls_semitones = unique(seq(ylim[1], ylim[2], length.out = 5))
# unique to remove duplicates, max 5 labels
lbls_notes = soundgen::notesDict$note[round(lbls_semitones) + 1]
lbls_Hz = round(semitonesToHz(lbls_semitones))
par(mar = c(5, 4, 4, 3)) # c(bottom, left, top, right)
plot(x, smoothContour_downsampled,
type = 'l', yaxt = "n", ylab = 'Frequency, Hz', xlab = 'Time, ms',
ylim = ylim, ...)
axis(2, at = lbls_semitones, labels = lbls_Hz, las = 1)
axis(4, at = lbls_semitones, labels = lbls_notes, las = 1)
points(anchors$time, anchors$value, col = 'blue', cex = 3)
} else {
# not pitch - not log-transformed
# if (!max(anchors$time) > 1) {
# anchors$time = anchors$time * duration_ms
# } # presuming that len was specified and anchors$time are on a
# # relative scale, we transform to ms for plotting
par(mar = c(5, 4, 4, 3)) # c(bottom, left, top, right)
if (is.null(xlim)) {
xlim = c(min(0, anchors$time[1]), anchors$time[length(anchors$time)])
}
if (is.null(ylim)) {
m1 = min(c(smoothContour, anchors$value))
m1 = ifelse(m1 > 0, m1 / 1.1, m1 * 1.1)
m2 = max(c(smoothContour, anchors$value))
m2 = ifelse(m2 > 0, m2 * 1.1, m1 / 1.1)
ylim = c(m1, m2)
# ylim = c(min(0, min(anchors$value)), max(0, max(anchors$value)))
}
# x = seq(anchors$time[1],
# anchors$time[length(anchors$time)],
# length.out = length(smoothContour_downsampled))
plot(x, y = smoothContour_downsampled, type = 'l', ylab = 'Amplitude',
xlab = 'Time, ms', xlim = xlim, ylim = ylim, ...)
points(anchors$time, anchors$value, col = 'blue', cex = 3)
if (is.numeric(voiced)) {
lines(x = c(0, voiced), y = c(0, 0), col = 'blue', lwd = 10)
text(x = voiced / 2, y = abs(ylim[2] - ylim[1]) / 25,
adj = 0.5, labels = 'voiced part', col = 'blue')
text(x = anchors$time[nrow(anchors)],
y = anchors$value[nrow(anchors)] - (ylim[2] - ylim[1]) / 25,
adj = 1, labels = contourLabel, col = 'red')
}
}
par("mar" = op) # restore original margin settings
}
# NA's may arise if the first anchor time > 0
if (nrow(anchors) > 0 & NA_to_zero)
smoothContour[is.na(smoothContour)] = 0
# floor / ceiling
smoothContour[smoothContour < valueFloor] = valueFloor
smoothContour[smoothContour > valueCeiling] = valueCeiling
if (thisIsPitch)
smoothContour = semitonesToHz(smoothContour)
return(smoothContour)
}
#' Draw contour
#'
#' Internal soundgen function
#'
#' The core part of getSmoothContour() that actually performs the interpolation
#' between anchors.
#' @inheritParams getSmoothContour
#' @param duration_ms contour duration, ms
#' @keywords internal
drawContour = function(len,
anchors,
interpol,
valueFloor,
duration_ms = 500,
loessSpan = NULL) {
time = 1:len
nr = nrow(anchors)
if (nr == len) return(anchors$value)
if (nr == 1) {
# flat
smoothContour = rep(anchors$value[1], len)
} else if (nr == 2) {
# linear
smoothContour = seq(anchors$value[1], anchors$value[2], length.out = len)
} else {
# smooth contour
if (interpol == 'approx') {
# approx can handle NAs, but we only really care about leading/trailing
# NAs, because NAs in the middle can be handled automatically
if (is.na(anchors$value[1]) | is.na(anchors$value[nr])) {
# if there are leading and/or trailing NAs, we have to upsample them separately
# replace trailing NA with the first / last non-NA values
idx_notNA = which(!is.na(anchors$value))
idx_na = which(is.na(anchors$value))
n_leading_na = round(len * anchors$time[idx_notNA[1]])
n_trailing_na = round(len * (1 - anchors$time[tail(idx_notNA, 1)]))
n_mid = len - n_leading_na - n_trailing_na
leading_na = trailing_na = numeric(0)
if (n_leading_na > 0)
leading_na = rep(NA, n_leading_na)
if (n_trailing_na > 0)
trailing_na = rep(NA, n_trailing_na)
mid_new = approx(x = anchors$time, y = anchors$value, n = n_mid, na.rm = FALSE)$y
smoothContour = c(leading_na, mid_new, trailing_na)
} else {
smoothContour = approx(anchors$value, n = len, x = anchors$time, na.rm = FALSE)$y
}
# plot(smoothContour, type='l')
} else if (interpol == 'spline') {
smoothContour = spline(anchors$value, n = len, x = anchors$time)$y
# plot(smoothContour, type='l')
} else if (interpol == 'loess') {
anchor_time_points = anchors$time - min(anchors$time)
anchor_time_points = anchor_time_points / max(anchor_time_points) * len
anchor_time_points[anchor_time_points == 0] = 1
anchors_long = as.vector(rep(NA, len))
anchors_long[anchor_time_points] = anchors$value # plot(anchors_long)
# let's draw a smooth curve through the given anchors
if (is.null(loessSpan)) {
span = (1 / (1 + exp(duration_ms / 500)) + 0.5) /
1.1 ^ (nrow(anchors) - 3)
} else {
span = loessSpan
}
# NB: need to compensate for variable number of points, namely decrease
# smoothing as the number of points increases, hence the "1.1^..." term
# duration_ms = 50:9000
# span = 1 / (1 + exp(duration_ms / 500)) + 0.5
# plot(duration_ms, span, type = 'l')
l = suppressWarnings(loess(anchors_long ~ time, span = span))
# plot(time, anchors_long)
smoothContour = try(predict(l, time), silent = TRUE)
# plot(time, smoothContour)
# for long duration etc, larger span may be needed to avoid error in loess
if (is.null(loessSpan)) {
while(inherits(smoothContour, 'try-error')) {
span = span + 0.1
l = suppressWarnings(loess(anchors_long ~ time, span = span))
smoothContour = try(predict(l, time), silent = TRUE)
}
# plot(smoothContour, type = 'l')
while(any(smoothContour < valueFloor - 1e-6, na.rm = TRUE)) {
# in case we get values below valueFloor, less smoothing should be used
# NB: -1e-6 avoids floating point problem, otherwise we get
# weird cases of -120 (float) < -120 (integer)
span = span / 1.1
l = suppressWarnings(loess(anchors_long ~ time, span = span))
smoothContour = try(predict(l, time), silent = TRUE)
}
}
}
return(smoothContour)
}
}
#' Split contour
#'
#' Internal soundgen function
#'
#' Splits a smooth contour into several segments. A new segments is started if
#' the time step between two anchors is smaller than discontThres.
#' @param anchors a dataframe with two columns: time and value (time on any scale)
#' @inheritParams getSmoothContour
#' @return Returns a dataframe containing the index of anchor rows for start and
#' end of each segment and whether we want a transition or a jump between
#' segments.
#' @keywords internal
#' @examples
#' soundgen:::splitContour(data.frame(time = c(0, 370, 650, 655, 1050, 1400),
#' value = c(360, 316, 345, 550, 610, 590)))
#' soundgen:::splitContour(data.frame(time = c(0, .2, .205, .8, .81, 1),
#' value = c(360, 316, 345, 550, 610, 590)))
#' soundgen:::splitContour(data.frame(time = c(0, .4, .45, .6, .8, 1),
#' value = c(360, 316, 345, 550, 610, 590)))
#' soundgen:::splitContour(data.frame(time = c(0, .4, .45, .6, .8, 1),
#' value = c(360, 316, 345, 550, 610, 590)),
#' discontThres = .1)
#' soundgen:::splitContour(data.frame(time = c(0, 1),
#' value = c(360, 590)))
splitContour = function(anchors,
discontThres = .05,
jumpThres = .01) {
discont = which(diff(anchors$time) / diff(range(anchors$time)) < discontThres)
jumps = which(diff(anchors$time) / diff(range(anchors$time)) < jumpThres)
if (length(discont) > 0) {
sections = data.frame(start = 1,
end = rep(nrow(anchors), length(discont) + 1),
jump = FALSE)
for (j in 1:length(discont)) {
sections$end[j] = discont[j]
sections$start[j + 1] = discont[j] + 1
sections$jump[j] = discont[j] %in% jumps
}
} else {
sections = data.frame(start = 1, end = nrow(anchors), jump = FALSE)
}
return(sections)
}
#' Discrete smooth contour from anchors
#'
#' Internal soundgen function.
#'
#' A discrete version of \code{\link{getSmoothContour}} with modified plotting.
#' Intended for plotting variation in parameters across syllables.
#' @param len the number of syllables (equivalently, the length of generated
#' contour)
#' @inheritParams getSmoothContour
#' @param ylim ylim for plotting
#' @return Numeric vector.
#' @keywords internal
#' @examples
#' # for a bout consisting of 10 syllables
#' soundgen:::getDiscreteContour(len = 10, interpol = 'spline', plot = TRUE,
#' ylab = 'Semitones', anchors = data.frame(time = c(0, .2, .6, 1),
#' value = c(0, -3, 1, 0)))
getDiscreteContour = function(len,
anchors = data.frame(time = c(0, 1), value = c(1, 1)),
interpol = c('spline', 'loess')[2],
valueFloor = NULL,
valueCeiling = NULL,
ylim = NULL,
plot = FALSE,
...) {
contour = getSmoothContour(
len = len,
anchors = anchors,
interpol = interpol,
valueFloor = valueFloor,
valueCeiling = valueCeiling
)
if (plot) {
if (is.null(ylim)) {
ylim = c(min(min(contour), min(anchors$value)),
max(max(contour), max(anchors$value)))
}
plot (contour, type = 'b', xlab = 'Syllable', col = 'red', bg = 'red',
cex = 1, pch = 23, ylim = ylim, ...)
points (x = anchors$time * (len - 1) + 1, y = anchors$value, col = 'blue',
cex = 3)
}
return(contour)
}
#' Reformat anchors
#'
#' Internal soundgen function.
#'
#' Checks that the anchors are formatted in a valid way and expands them to a
#' standard dataframe with two columns: time and value. NB: works for all
#' anchors except "noise", whose anchors have to be scaled by sylLen and are
#' therefore processed directly in soundgen()
#' @param anchors a numeric vector of values or a list/dataframe with one column
#' (value) or two columns (time and value)
#' @param normalizeTime if TRUE, normalizes anchors$time values to range from 0 to 1
#' @keywords internal
#' @examples
#' soundgen:::reformatAnchors(150)
#' soundgen:::reformatAnchors(c(150, 200, 220))
#' soundgen:::reformatAnchors(anchors = list(value=c(150, 200, 220)))
#' soundgen:::reformatAnchors(anchors = list(time = c(0, 10, 100),
#' value = c(150, 200, 220)))
#' # returns NA
#' soundgen:::reformatAnchors('aha')
#' \dontrun{
#' # returns NA with a warning
#' soundgen:::reformatAnchors(anchors = list(time = c(0, .1, 1),
#' freq = c(150, 200, 220)))
#'
#' # throws a warning and rearranges in order of time stamps
#' soundgen:::reformatAnchors(anchors = list(time = c(0, .8, .7, 1),
#' value = c(150, 200, 150, 220)))
#' }
reformatAnchors = function(anchors, normalizeTime = TRUE) {
if (is.numeric(anchors)) {
# for numeric vectors, assume these are equally spaced anchor values
anchors_df = data.frame(
time = seq(0, 1, length.out = max(2, length(anchors))),
value = anchors
)
} else if (is.list(anchors)) {
# for dataframes or lists, reformat if necessary
if (!is.data.frame(anchors)) {
anchors_df = as.data.frame(anchors)
} else {
anchors_df = anchors
}
if (ncol(anchors_df) == 1) {
# if there is only one vector, again assume these are values
anchors_df = data.frame(
time = seq(0, 1, length.out = max(2, nrow(anchors_df))),
value = anchors_df[, 1]
)
} else if (!identical(colnames(anchors_df), c('time', 'value'))) {
warning(paste('An anchor should be either numeric or a dataframe',
'with two columns: time and value.'))
return(NA)
}
} else {
return(NA)
}
# make sure time values are in the right order
if (any(diff(anchors_df$time) < 0)) {
anchors_df = anchors_df[order(anchors_df$time), ]
warning('Time stamps of anchors should increase monotonically; re-ordering...')
}
# make sure time ranges from 0 to 1
if (normalizeTime) anchors_df$time = zeroOne(anchors_df$time)
return(anchors_df)
}
Try the soundgen package in your browser
Any scripts or data that you put into this service are public.
soundgen documentation built on Aug. 14, 2022, 5:05 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions reformatAnchors getDiscreteContour splitContour drawContour getSmoothContour
Documented in drawContour getDiscreteContour getSmoothContour reformatAnchors splitContour
# Functions for generating and modifying smooth contours from a few anchors
#' Smooth contour from anchors
#'
#' Returns a smooth contour based on an arbitrary number of anchors. Used by
#' \code{\link{soundgen}} for generating intonation contour, mouth opening, etc.
#' This function is mostly intended to be used internally by soundgen, more
#' precisely to construct (upsample) smooth curves from a number of anchors. For
#' general upsampling or downsampling of audio, use \code{\link{resample}}. Note
#' that pitch contours are treated as a special case: values are log-transformed
#' prior to smoothing, so that with 2 anchors we get a linear transition on a
#' log scale (as if we were operating with musical notes rather than frequencies
#' in Hz). Pitch plots have two Y axes: one showing Hz and the other showing
#' musical notation.
#' @param anchors a numeric vector of values or a list/dataframe with one column
#' (value) or two columns (time and value). \code{achors$time} can be in ms
#' (with len=NULL) or in arbitrary units, eg 0 to 1 (with duration determined
#' by len, which must then be provided in ms). So anchors$time is assumed to
#' be in ms if len=NULL and relative if len is specified. \code{anchors$value}
#' can be on any scale.
#' @param len the required length of the output contour. If NULL, it will be
#' calculated based on the maximum time value (in ms) and \code{samplingRate}
#' @param thisIsPitch (boolean) is this a pitch contour? If true, log-transforms
#' before smoothing and plots in both Hz and musical notation
#' @param normalizeTime if TRUE, normalizes anchors$time values to range from 0 to 1
#' @param interpol method of interpolation between anchors: "approx" = linear
#' with \code{\link{approx}}, "spline" = cubic splines with
#' \code{\link{spline}}, "loess" = local polynomial regression with
#' \code{\link{loess}}
#' @param loessSpan controls the amount of smoothing when interpolating between
#' anchors with \code{\link[stats]{loess}}, so only has an effect if interpol
#' = 'loess' (1 = strong, 0.5 = weak smoothing)
#' @param discontThres if two anchors are closer in time than
#' \code{discontThres} (on a 0-1 scale, ie specified as proportion of total
#' length), the contour is broken into segments with a linear transition
#' between these segments
#' @param jumpThres if anchors are closer than \code{jumpThres}, a new section
#' starts with no transition at all (e.g. for adding pitch jumps)
#' @param valueFloor,valueCeiling lowser/upper bounds for the contour
#' @param plot (boolean) produce a plot?
#' @param samplingRate sampling rate used to convert time values to points (Hz)
#' @param voiced,contourLabel graphical pars for plotting breathing contours
#' (see examples below)
#' @param NA_to_zero if TRUE, all NAs are replaced with zero
#' @param xlim,ylim plotting options
#' @param ... other plotting options passed to \code{plot()}
#' @export
#' @return Returns a numeric vector of length \code{len}.
#' @examples
#' # long format: anchors are a dataframe
#' a = getSmoothContour(anchors = data.frame(
#' time = c(50, 137, 300), value = c(0.03, 0.78, 0.5)),
#' normalizeTime = FALSE,
#' voiced = 200, valueFloor = 0, plot = TRUE, main = '',
#' samplingRate = 16000) # breathing
#'
#' # short format: anchors are a vector (equal time steps assumed)
#' a = getSmoothContour(anchors = c(350, 800, 600),
#' len = 5500, thisIsPitch = TRUE, plot = TRUE,
#' samplingRate = 3500) # pitch
#'
#' # a single anchor gives constant value
#' a = getSmoothContour(anchors = 800,
#' len = 500, thisIsPitch = TRUE, plot = TRUE, samplingRate = 500)
#'
#' # two pitch anchors give loglinear F0 change
#' a = getSmoothContour(anchors = c(220, 440),
#' len = 500, thisIsPitch = TRUE, plot = TRUE, samplingRate = 500)
#'
#' ## Two closely spaced anchors produce a pitch jump
#' # one loess for the entire contour
#' a1 = getSmoothContour(anchors = list(time = c(0, .15, .2, .7, 1),
#' value = c(360, 116, 550, 700, 610)), len = 500, thisIsPitch = TRUE,
#' plot = TRUE, samplingRate = 500)
#' # two segments with a linear transition
#' a2 = getSmoothContour(anchors = list(time = c(0, .15, .17, .7, 1),
#' value = c(360, 116, 550, 700, 610)), len = 500, thisIsPitch = TRUE,
#' plot = TRUE, samplingRate = 500)
#' # two segments with an abrupt jump
#' a3 = getSmoothContour(anchors = list(time = c(0, .15, .155, .7, 1),
#' value = c(360, 116, 550, 700, 610)), len = 500, thisIsPitch = TRUE,
#' plot = TRUE, samplingRate = 500)
#' # compare:
#' plot(a2)
#' plot(a3) # NB: the segment before the jump is upsampled to compensate
#'
#' ## Control the amount of smoothing
#' getSmoothContour(c(1, 3, 9, 10, 9, 9, 2), len = 100, plot = TRUE,
#' loessSpan = NULL) # default amount of smoothing (depends on dur)
#' getSmoothContour(c(1, 3, 9, 10, 9, 9, 2), len = 100, plot = TRUE,
#' loessSpan = .85) # more smoothing than default
#' getSmoothContour(c(1, 3, 9, 10, 9, 9, 2), len = 100, plot = TRUE,
#' loessSpan = .5) # less smoothing
#' getSmoothContour(c(1, 3, 9, 10, 9, 9, 2), len = 100, plot = TRUE,
#' interpol = 'approx') # linear interpolation (no smoothing)
#'
#' ## Upsample preserving leading and trailing NAs
#' anchors = data.frame(time = c(1, 4, 5, 7, 10, 20, 23, 25, 30),
#' value = c(NA, NA, 10, 15, 12, NA, 17, 15, NA))
#' plot(anchors, type = 'b')
#' anchors_ups = getSmoothContour(
#' anchors, len = 200,
#' interpol = 'approx', # only approx can propagate NAs
#' NA_to_zero = FALSE, # preserve NAs
#' discontThres = 0) # don't break into sub-contours
#' plot(anchors_ups, type = 'b')
getSmoothContour = function(
anchors = data.frame(time = c(0, 1), value = c(0, 1)),
len = NULL,
thisIsPitch = FALSE,
normalizeTime = TRUE,
interpol = c('approx', 'spline', 'loess')[3],
loessSpan = NULL,
discontThres = .05,
jumpThres = .01,
valueFloor = NULL,
valueCeiling = NULL,
plot = FALSE,
xlim = NULL,
ylim = NULL,
samplingRate = 16000,
voiced = NULL,
contourLabel = NULL,
NA_to_zero = TRUE,
...) {
my_args = match.call()
if (is.null(my_args$main)) {
if (thisIsPitch)
main = 'Pitch contour'
else
main = ''
}
# if (is.null(my_args$main)) {
anchors = reformatAnchors(anchors, normalizeTime = normalizeTime)
if (!is.null(len) && len == 1) return(anchors$value[1])
if (is.list(anchors)) {
if (nrow(anchors) > 10 & nrow(anchors) < 50 & interpol == 'loess') {
interpol = 'spline'
# warning('More than 10 anchors; changing interpolation method from loess to spline')
} else if (nrow(anchors) > 50) {
interpol = 'approx'
}
} else {
stop('Invalid format of the "anchors" argument')
}
if (!is.null(valueFloor)) {
anchors$value[anchors$value < valueFloor] = valueFloor
}
if (!is.null(valueCeiling)) {
anchors$value[anchors$value > valueCeiling] = valueCeiling
}
if (thisIsPitch) {
anchors$value = HzToSemitones(anchors$value)
if (!is.null(valueFloor))
valueFloor = HzToSemitones(valueFloor)
if (!is.null(valueCeiling))
valueCeiling = HzToSemitones(valueCeiling)
}
if (is.null(len)) {
# if len is null, we expect that anchors$time encoded
# the desired duration, in ms
duration_ms = max(anchors$time) - min(anchors$time)
len = floor(duration_ms * samplingRate / 1000)
} else {
anchors$time = anchors$time - min(anchors$time)
anchors$time = anchors$time / max(anchors$time) # strictly 0 to 1
duration_ms = len / samplingRate * 1000
}
if (!is.numeric(duration_ms) | !is.numeric(len)) {
return(NA)
} else if (duration_ms == 0 | len == 0) {
return(NA)
}
if (NA_to_zero) anchors$value[is.na(anchors$value)] = 0
# get smooth contours
nr = nrow(anchors)
if (nr == len) {
# nothing to do
smoothContour = anchors$value
} else if (nr > len) {
# downsample
smoothContour = suppressWarnings(.resample(list(sound = anchors$value),
mult = len / nr))
} else if (discontThres <= 0 | nr < 3) {
# upsample in one go
smoothContour = drawContour(len = len,
anchors = anchors,
interpol = interpol,
loessSpan = loessSpan,
valueFloor = valueFloor,
duration_ms = duration_ms)
} else {
# some anchors might be too close, so we split the contour into segments
# to avoid weird behavior of loess etc
sections = splitContour(anchors = anchors,
discontThres = discontThres,
jumpThres = jumpThres)
smoothContour = vector()
for (i in 1:nrow(sections)) {
segm_len = round((anchors$time[sections$end[i]] -
anchors$time[sections$start[i]]) /
diff(range(anchors$time)) * len)
cont = drawContour(len = segm_len,
anchors = anchors[sections$start[i]:sections$end[i], ],
interpol = interpol,
loessSpan = loessSpan,
valueFloor = valueFloor,
duration_ms = duration_ms)
transition = vector()
if (i < nrow(sections)) {
trans_len = round((anchors$time[sections$start[i + 1]] -
anchors$time[sections$end[i]]) /
diff(range(anchors$time)) * len)
if (sections$jump[i] & length(cont) > 0) {
# upsample the segment before the jump to make up for skipped transition
cont = approx(cont, n = length(cont) + trans_len)$y
} else {
# make a linear transition preserving spacing between anchors
transition = seq(anchors$value[sections$end[i]],
anchors$value[sections$start[i + 1]],
length.out = trans_len)
}
}
smoothContour = c(smoothContour, cont, transition)
}
if (length(smoothContour) != len) {
smoothContour = approx(smoothContour, n = len)$y
}
}
# plot(smoothContour, type='p')
if (plot) {
idx = seq(1, len, length.out = min(len, 100))
op = par("mar") # save user's original margin settings
if (len > 100) {
# for plotting, shorten smoothContour to max 100 points
# to reduce processing load
smoothContour_downsampled = smoothContour[idx]
} else {
smoothContour_downsampled = smoothContour
}
# plot(smoothContour_downsampled)
# presuming that len was specified and anchors$time are on a
# relative scale, we transform to ms for plotting
if (!max(anchors$time) > 1) {
anchors$time = anchors$time * duration_ms
time = seq(0, len, length.out = len)
x = time[idx] / samplingRate * 1000
} else { # time is already in ms
time = seq(anchors$time[1], anchors$time[nrow(anchors)], length.out = len)
x = time[idx]
}
if (thisIsPitch) {
# pitch - log-transformed
if (!is.numeric(ylim)) {
ylim = c(
min(smoothContour_downsampled) / 1.1, # can't be negative
max(smoothContour_downsampled) * 1.1
)
} else if (min(smoothContour_downsampled) < HzToSemitones(ylim[1])) {
ylim[1] = min(smoothContour_downsampled) / 1.1
} else if (max(smoothContour_downsampled) > HzToSemitones(ylim[2])) {
ylim[2] = max(smoothContour_downsampled) * 1.1
} else {
ylim = HzToSemitones(ylim)
}
lbls_semitones = unique(seq(ylim[1], ylim[2], length.out = 5))
# unique to remove duplicates, max 5 labels
lbls_notes = soundgen::notesDict$note[round(lbls_semitones) + 1]
lbls_Hz = round(semitonesToHz(lbls_semitones))
par(mar = c(5, 4, 4, 3)) # c(bottom, left, top, right)
plot(x, smoothContour_downsampled,
type = 'l', yaxt = "n", ylab = 'Frequency, Hz', xlab = 'Time, ms',
ylim = ylim, ...)
axis(2, at = lbls_semitones, labels = lbls_Hz, las = 1)
axis(4, at = lbls_semitones, labels = lbls_notes, las = 1)
points(anchors$time, anchors$value, col = 'blue', cex = 3)
} else {
# not pitch - not log-transformed
# if (!max(anchors$time) > 1) {
# anchors$time = anchors$time * duration_ms
# } # presuming that len was specified and anchors$time are on a
# # relative scale, we transform to ms for plotting
par(mar = c(5, 4, 4, 3)) # c(bottom, left, top, right)
if (is.null(xlim)) {
xlim = c(min(0, anchors$time[1]), anchors$time[length(anchors$time)])
}
if (is.null(ylim)) {
m1 = min(c(smoothContour, anchors$value))
m1 = ifelse(m1 > 0, m1 / 1.1, m1 * 1.1)
m2 = max(c(smoothContour, anchors$value))
m2 = ifelse(m2 > 0, m2 * 1.1, m1 / 1.1)
ylim = c(m1, m2)
# ylim = c(min(0, min(anchors$value)), max(0, max(anchors$value)))
}
# x = seq(anchors$time[1],
# anchors$time[length(anchors$time)],
# length.out = length(smoothContour_downsampled))
plot(x, y = smoothContour_downsampled, type = 'l', ylab = 'Amplitude',
xlab = 'Time, ms', xlim = xlim, ylim = ylim, ...)
points(anchors$time, anchors$value, col = 'blue', cex = 3)
if (is.numeric(voiced)) {
lines(x = c(0, voiced), y = c(0, 0), col = 'blue', lwd = 10)
text(x = voiced / 2, y = abs(ylim[2] - ylim[1]) / 25,
adj = 0.5, labels = 'voiced part', col = 'blue')
text(x = anchors$time[nrow(anchors)],
y = anchors$value[nrow(anchors)] - (ylim[2] - ylim[1]) / 25,
adj = 1, labels = contourLabel, col = 'red')
}
}
par("mar" = op) # restore original margin settings
}
# NA's may arise if the first anchor time > 0
if (nrow(anchors) > 0 & NA_to_zero)
smoothContour[is.na(smoothContour)] = 0
# floor / ceiling
smoothContour[smoothContour < valueFloor] = valueFloor
smoothContour[smoothContour > valueCeiling] = valueCeiling
if (thisIsPitch)
smoothContour = semitonesToHz(smoothContour)
return(smoothContour)
}
#' Draw contour
#'
#' Internal soundgen function
#'
#' The core part of getSmoothContour() that actually performs the interpolation
#' between anchors.
#' @inheritParams getSmoothContour
#' @param duration_ms contour duration, ms
#' @keywords internal
drawContour = function(len,
anchors,
interpol,
valueFloor,
duration_ms = 500,
loessSpan = NULL) {
time = 1:len
nr = nrow(anchors)
if (nr == len) return(anchors$value)
if (nr == 1) {
# flat
smoothContour = rep(anchors$value[1], len)
} else if (nr == 2) {
# linear
smoothContour = seq(anchors$value[1], anchors$value[2], length.out = len)
} else {
# smooth contour
if (interpol == 'approx') {
# approx can handle NAs, but we only really care about leading/trailing
# NAs, because NAs in the middle can be handled automatically
if (is.na(anchors$value[1]) | is.na(anchors$value[nr])) {
# if there are leading and/or trailing NAs, we have to upsample them separately
# replace trailing NA with the first / last non-NA values
idx_notNA = which(!is.na(anchors$value))
idx_na = which(is.na(anchors$value))
n_leading_na = round(len * anchors$time[idx_notNA[1]])
n_trailing_na = round(len * (1 - anchors$time[tail(idx_notNA, 1)]))
n_mid = len - n_leading_na - n_trailing_na
leading_na = trailing_na = numeric(0)
if (n_leading_na > 0)
leading_na = rep(NA, n_leading_na)
if (n_trailing_na > 0)
trailing_na = rep(NA, n_trailing_na)
mid_new = approx(x = anchors$time, y = anchors$value, n = n_mid, na.rm = FALSE)$y
smoothContour = c(leading_na, mid_new, trailing_na)
} else {
smoothContour = approx(anchors$value, n = len, x = anchors$time, na.rm = FALSE)$y
}
# plot(smoothContour, type='l')
} else if (interpol == 'spline') {
smoothContour = spline(anchors$value, n = len, x = anchors$time)$y
# plot(smoothContour, type='l')
} else if (interpol == 'loess') {
anchor_time_points = anchors$time - min(anchors$time)
anchor_time_points = anchor_time_points / max(anchor_time_points) * len
anchor_time_points[anchor_time_points == 0] = 1
anchors_long = as.vector(rep(NA, len))
anchors_long[anchor_time_points] = anchors$value # plot(anchors_long)
# let's draw a smooth curve through the given anchors
if (is.null(loessSpan)) {
span = (1 / (1 + exp(duration_ms / 500)) + 0.5) /
1.1 ^ (nrow(anchors) - 3)
} else {
span = loessSpan
}
# NB: need to compensate for variable number of points, namely decrease
# smoothing as the number of points increases, hence the "1.1^..." term
# duration_ms = 50:9000
# span = 1 / (1 + exp(duration_ms / 500)) + 0.5
# plot(duration_ms, span, type = 'l')
l = suppressWarnings(loess(anchors_long ~ time, span = span))
# plot(time, anchors_long)
smoothContour = try(predict(l, time), silent = TRUE)
# plot(time, smoothContour)
# for long duration etc, larger span may be needed to avoid error in loess
if (is.null(loessSpan)) {
while(inherits(smoothContour, 'try-error')) {
span = span + 0.1
l = suppressWarnings(loess(anchors_long ~ time, span = span))
smoothContour = try(predict(l, time), silent = TRUE)
}
# plot(smoothContour, type = 'l')
while(any(smoothContour < valueFloor - 1e-6, na.rm = TRUE)) {
# in case we get values below valueFloor, less smoothing should be used
# NB: -1e-6 avoids floating point problem, otherwise we get
# weird cases of -120 (float) < -120 (integer)
span = span / 1.1
l = suppressWarnings(loess(anchors_long ~ time, span = span))
smoothContour = try(predict(l, time), silent = TRUE)
}
}
}
return(smoothContour)
}
}
#' Split contour
#'
#' Internal soundgen function
#'
#' Splits a smooth contour into several segments. A new segments is started if
#' the time step between two anchors is smaller than discontThres.
#' @param anchors a dataframe with two columns: time and value (time on any scale)
#' @inheritParams getSmoothContour
#' @return Returns a dataframe containing the index of anchor rows for start and
#' end of each segment and whether we want a transition or a jump between
#' segments.
#' @keywords internal
#' @examples
#' soundgen:::splitContour(data.frame(time = c(0, 370, 650, 655, 1050, 1400),
#' value = c(360, 316, 345, 550, 610, 590)))
#' soundgen:::splitContour(data.frame(time = c(0, .2, .205, .8, .81, 1),
#' value = c(360, 316, 345, 550, 610, 590)))
#' soundgen:::splitContour(data.frame(time = c(0, .4, .45, .6, .8, 1),
#' value = c(360, 316, 345, 550, 610, 590)))
#' soundgen:::splitContour(data.frame(time = c(0, .4, .45, .6, .8, 1),
#' value = c(360, 316, 345, 550, 610, 590)),
#' discontThres = .1)
#' soundgen:::splitContour(data.frame(time = c(0, 1),
#' value = c(360, 590)))
splitContour = function(anchors,
discontThres = .05,
jumpThres = .01) {
discont = which(diff(anchors$time) / diff(range(anchors$time)) < discontThres)
jumps = which(diff(anchors$time) / diff(range(anchors$time)) < jumpThres)
if (length(discont) > 0) {
sections = data.frame(start = 1,
end = rep(nrow(anchors), length(discont) + 1),
jump = FALSE)
for (j in 1:length(discont)) {
sections$end[j] = discont[j]
sections$start[j + 1] = discont[j] + 1
sections$jump[j] = discont[j] %in% jumps
}
} else {
sections = data.frame(start = 1, end = nrow(anchors), jump = FALSE)
}
return(sections)
}
#' Discrete smooth contour from anchors
#'
#' Internal soundgen function.
#'
#' A discrete version of \code{\link{getSmoothContour}} with modified plotting.
#' Intended for plotting variation in parameters across syllables.
#' @param len the number of syllables (equivalently, the length of generated
#' contour)
#' @inheritParams getSmoothContour
#' @param ylim ylim for plotting
#' @return Numeric vector.
#' @keywords internal
#' @examples
#' # for a bout consisting of 10 syllables
#' soundgen:::getDiscreteContour(len = 10, interpol = 'spline', plot = TRUE,
#' ylab = 'Semitones', anchors = data.frame(time = c(0, .2, .6, 1),
#' value = c(0, -3, 1, 0)))
getDiscreteContour = function(len,
anchors = data.frame(time = c(0, 1), value = c(1, 1)),
interpol = c('spline', 'loess')[2],
valueFloor = NULL,
valueCeiling = NULL,
ylim = NULL,
plot = FALSE,
...) {
contour = getSmoothContour(
len = len,
anchors = anchors,
interpol = interpol,
valueFloor = valueFloor,
valueCeiling = valueCeiling
)
if (plot) {
if (is.null(ylim)) {
ylim = c(min(min(contour), min(anchors$value)),
max(max(contour), max(anchors$value)))
}
plot (contour, type = 'b', xlab = 'Syllable', col = 'red', bg = 'red',
cex = 1, pch = 23, ylim = ylim, ...)
points (x = anchors$time * (len - 1) + 1, y = anchors$value, col = 'blue',
cex = 3)
}
return(contour)
}
#' Reformat anchors
#'
#' Internal soundgen function.
#'
#' Checks that the anchors are formatted in a valid way and expands them to a
#' standard dataframe with two columns: time and value. NB: works for all
#' anchors except "noise", whose anchors have to be scaled by sylLen and are
#' therefore processed directly in soundgen()
#' @param anchors a numeric vector of values or a list/dataframe with one column
#' (value) or two columns (time and value)
#' @param normalizeTime if TRUE, normalizes anchors$time values to range from 0 to 1
#' @keywords internal
#' @examples
#' soundgen:::reformatAnchors(150)
#' soundgen:::reformatAnchors(c(150, 200, 220))
#' soundgen:::reformatAnchors(anchors = list(value=c(150, 200, 220)))
#' soundgen:::reformatAnchors(anchors = list(time = c(0, 10, 100),
#' value = c(150, 200, 220)))
#' # returns NA
#' soundgen:::reformatAnchors('aha')
#' \dontrun{
#' # returns NA with a warning
#' soundgen:::reformatAnchors(anchors = list(time = c(0, .1, 1),
#' freq = c(150, 200, 220)))
#'
#' # throws a warning and rearranges in order of time stamps
#' soundgen:::reformatAnchors(anchors = list(time = c(0, .8, .7, 1),
#' value = c(150, 200, 150, 220)))
#' }
reformatAnchors = function(anchors, normalizeTime = TRUE) {
if (is.numeric(anchors)) {
# for numeric vectors, assume these are equally spaced anchor values
anchors_df = data.frame(
time = seq(0, 1, length.out = max(2, length(anchors))),
value = anchors
)
} else if (is.list(anchors)) {
# for dataframes or lists, reformat if necessary
if (!is.data.frame(anchors)) {
anchors_df = as.data.frame(anchors)
} else {
anchors_df = anchors
}
if (ncol(anchors_df) == 1) {
# if there is only one vector, again assume these are values
anchors_df = data.frame(
time = seq(0, 1, length.out = max(2, nrow(anchors_df))),
value = anchors_df[, 1]
)
} else if (!identical(colnames(anchors_df), c('time', 'value'))) {
warning(paste('An anchor should be either numeric or a dataframe',
'with two columns: time and value.'))
return(NA)
}
} else {
return(NA)
}
# make sure time values are in the right order
if (any(diff(anchors_df$time) < 0)) {
anchors_df = anchors_df[order(anchors_df$time), ]
warning('Time stamps of anchors should increase monotonically; re-ordering...')
}
# make sure time ranges from 0 to 1
if (normalizeTime) anchors_df$time = zeroOne(anchors_df$time)
return(anchors_df)
}
Try the soundgen package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.