R/it.R

Defines functions it.getPointIndexNearestTime it.getPointIndexLowerThanTime it.getPointIndexHigherThanTime as.it it.cut0 it.cut it.legendreDemo it.legendreSynth it.legendre it.interpolate it.plot it.write0 it.write it.read_lines it.read

Documented in as.it it.cut it.cut0 it.getPointIndexHigherThanTime it.getPointIndexLowerThanTime it.getPointIndexNearestTime it.interpolate it.legendre it.legendreDemo it.legendreSynth it.plot it.read it.write

#' it.read
#'
#' Reads IntensityTier from Praat. Supported formats: text file, short text file.
#'
#' @param fileNameIntensityTier file name of IntensityTier
#' @param encoding File encoding (default: \code{"UTF-8"}), \code{"auto"} for auto-detect of Unicode encoding
#'
#' @return IntensityTier object
#' @export
#' @seealso \code{\link{it.write}}, \code{\link{it.plot}}, \code{\link{it.cut}}, \code{\link{it.cut0}}, \code{\link{it.interpolate}}, \code{\link{tg.read}}, \code{\link{pt.read}}, \code{\link{pitch.read}}, \code{\link{formant.read}}, \code{\link{col.read}}
#'
#' @examples
#' \dontrun{
#' it <- it.read("demo/maminka.IntensityTier")
#' it.plot(it)
#' }
it.read <- function(fileNameIntensityTier, encoding = "UTF-8") {
    if (!isString(fileNameIntensityTier)) {
        stop("Invalid 'fileNameIntensityTier' parameter.")
    }

    if (!isString(encoding)) {
        stop("Invalid 'encoding' parameter.")
    }
    enc <- encoding

    if (encoding == "auto") {
        enc <- detectEncoding(fileNameIntensityTier)
    }

    if (enc == "UTF-8") {
        flines <- readr::read_lines(fileNameIntensityTier, locale = readr::locale(encoding = "UTF-8"))  # Does not support UTF-16 at this point :-(
    } else {
        fid <- file(fileNameIntensityTier, open = "r", encoding = enc)
        flines <- readLines(fid)
        close(fid)
    }

    flines <- enc2utf8(flines)


    if (length(flines) < 1) {
        stop("Empty file.")
    }

    if (encoding == "UTF-8" & flines[1] != 'File type = "ooTextFile"') {
        warning('Not an UTF-8 IntensityTier format, trying encoding = "auto"...')
        x <- it.read(fileNameIntensityTier, encoding = "auto")
        return(x)
    }

    it_ind <- it.read_lines(flines)
    class(it_ind[[1]])["type"] <- "IntensityTier"
    class(it_ind[[1]])["name"] <- basename(fileNameIntensityTier)
    return(it_ind[[1]])
}

it.read_lines <- function(flines, find = 1, collection = FALSE) {
    if (collection  ||  flines[find-1+1] == "File type = \"ooTextFile\"") {    # TextFile or shortTextFile - only these 2 formats can be stored in collection file
        if (!collection) {
            if (length(flines)-find+1 < 6) {
                stop("Unknown IntensityTier format.")
            }

            if (strTrim(flines[find-1+2]) != "Object class = \"IntensityTier\"") {
                stop("Unknown IntensityTier format.")
            }

            if (strTrim(flines[find-1+3]) != "") {
                stop("Unknown IntensityTier format.")
            }

            if (strTrim(nchar(flines[find-1+4])) < 1) {
                stop("Unknown IntensityTier format.")
            }
        } else {
            find <- find - 3
        }

        if (str_contains(flines[find-1+4], "xmin")) {  # TextFile
            xmin <- as.numeric(substr(strTrim(flines[find-1+4]), 8,  nchar(strTrim(flines[find-1+4]))))
            xmax <- as.numeric(substr(strTrim(flines[find-1+5]), 8,  nchar(strTrim(flines[find-1+5]))))
            N <-    as.numeric(substr(strTrim(flines[find-1+6]), 16, nchar(strTrim(flines[find-1+6]))))

            t <- numeric(N)
            i <- numeric(N)

            for (I in seqM(1, N, by = 1)) {
                t[I] <- as.numeric(substr(strTrim(flines[find-1+8 + (I-1)*3]), 10, nchar(strTrim(flines[find-1+8 + (I-1)*3]))))
                i[I] <- as.numeric(substr(strTrim(flines[find-1+9 + (I-1)*3]), 9, nchar(strTrim(flines[find-1+9 + (I-1)*3]))))
            }

            find <- find-1+9 + (N-1)*3 + 1

        } else {   # shortTextFile

            xmin <- as.numeric(flines[find-1+4])
            xmax <- as.numeric(flines[find-1+5])
            N <- as.integer(flines[find-1+6])

            t <- numeric(N)
            i <- numeric(N)

            for (I in seqM(1, N, by = 1)) {
                t[I] <- as.numeric(flines[find-1+7 + (I-1)*2])
                i[I] <- as.numeric(flines[find-1+8 + (I-1)*2])
            }

            find <- find-1+8 + (N-1)*2 + 1
        }


    } else {
        stop("unsupported IntensityTier format")
    }


    it <- list(t = t, i = i, tmin = xmin, tmax = xmax)

    return(list(it, find))
}

#' it.write
#'
#' Saves IntensityTier to file (in UTF-8 encoding).
#' it is list with at least \code{$t} and \code{$i} vectors (of the same length).
#' If there are no \code{$tmin} and \code{$tmax} values, there are
#' set as min and max of \code{$t} vector.
#'
#' @param it IntensityTier object
#' @param fileNameIntensityTier file name to be created
#' @param format Output file format (\code{"short"} (short text format - default), \code{"text"} (a.k.a. full text format))
#'
#' @export
#' @seealso \code{\link{it.read}}, \code{\link{tg.write}}, \code{\link{it.interpolate}}
#'
#' @examples
#' \dontrun{
#' it <- it.sample()
#' it.plot(pt)
#' it.write(it, "demo/intensity.IntensityTier")
#' }
it.write <- function(it, fileNameIntensityTier, format = "short") {
    it.write0(it, fileNameIntensityTier, format)
}

it.write0 <- function(it, fileNameIntensityTier, format = "short", fid = NULL, collection = FALSE) {
    if (!isString(fileNameIntensityTier)) {
        stop("Invalid 'fileNameIntensityTier' parameter.")
    }

    if (!isString(format)) {
        stop("Invalid 'format' parameter.")
    }

    if (format != "short" && format != "text") {
        stop("Unsupported format (supported: short [default], text)")
    }

    if (!("t" %in% names(it))) {
        stop("it must be a list with 't' and 'i' and optionally 'tmin' and 'tmax'")
    }
    if (!("i" %in% names(it))) {
        stop("it must be a list with 't' and 'i' and optionally 'tmin' and 'tmax'")
    }
    if (length(it$t) != length(it$i)) {
        stop("t and i lengths mismatched.")
    }
    N <- length(it$t)


    if (!("tmin" %in% names(it))) {
        xmin <- min(it$t)
    } else {
        xmin <- it$tmin
    }
    if (!("tmax" %in% names(it))) {
        xmax <- max(it$t)
    } else {
        xmax <- it$tmax
    }


    if (!collection) {
        fid <- file(fileNameIntensityTier, open = "wb", encoding = "UTF-8")
        if (!isOpen(fid)) {
            stop(paste0("cannot open file [", fileNameIntensityTier, "]"))
        }
    }

    if (!collection) {
        if (format == "short" || format == "text") {
            wrLine('File type = "ooTextFile"', fid)
            wrLine('Object class = "IntensityTier"', fid)
            wrLine('', fid)
        }
    }

    if (format == "short") {
        wrLine(as.character(round2(xmin, -15)), fid)
        wrLine(as.character(round2(xmax, -15)), fid)
        wrLine(as.character(N), fid)
    } else if (format == "text") {
        wrLine(paste0("xmin = ", as.character(round2(xmin, -15)), " "), fid, collection)
        wrLine(paste0("xmax = ", as.character(round2(xmax, -15)), " "), fid, collection)
        wrLine(paste0("points: size = ", as.character(N), " "), fid, collection)
    }

    for (n in seqM(1, N)) {
        if (format == "short") {
            wrLine(as.character(round2(it$t[n], -15)), fid)
            wrLine(as.character(round2(it$i[n], -15)), fid)
        } else if (format == "text") {
            wrLine(paste0("points [", as.character(n), "]:"), fid, collection)
            wrLine(paste0("    number = ", as.character(round2(it$t[n], -15)), " "), fid, collection)
            wrLine(paste0("    value = ", as.character(round2(it$i[n], -15)), " "), fid, collection)
        }
    }

    if (!collection) {
        close(fid)
    }
}


#' it.plot
#'
#' Plots interactive IntensityTier using \code{dygraphs} package.
#'
#' @param it IntensityTier object
#' @param group [optional] character string, name of group for dygraphs synchronization
#' @param snd [optional] Sound object
#'
#' @export
#' @seealso \code{\link{it.read}}, \code{\link{tg.plot}}, \code{\link{it.cut}}, \code{\link{it.cut0}}, \code{\link{it.interpolate}}, \code{\link{it.write}}
#'
#' @examples
#' \dontrun{
#' it <- it.sample()
#' it.plot(it)
#' }
it.plot <- function(it, group = "", snd = NULL) {
    tAll <- it$t

    if (!is.null(snd)) {
        if (is.null(nrow(snd$sig))) {
            nsamples <- length(snd$sig) # vector, not a matrix
        } else {
            nsamples <- nrow(snd$sig)   # matrix
        }

        if (!("nChannels" %in% names(snd))) {
            if (is.null(ncol(snd$sig))) {
                snd$nChannels <- 1  # probably a vector
            } else {
                snd$nChannels <- ncol(snd$sig)
            }
        }

        if (!("t" %in% names(snd))) {
            snd$t <- seqM(0, nsamples-1)/snd$fs
        }

        tAll <- c(tAll, snd$t)
    }

    tAll <- unique(sort(tAll))

    data <- list(t = tAll)
    y2 <- rep(as.numeric(NA), length(tAll))  ### it
    y2[tAll %in% it$t] <- it$i
    data[[length(data)+1]] <- y2
    names(data)[length(data)] <- "IntensityTier"

    if (!is.null(snd)) {
        if (snd$nChannels == 1) {
            if (is.null(nrow(snd$sig))) {
                ch1 <- snd$sig  # probably a vector
            } else {
                ch1 <- snd$sig[, 1]
            }
            y2 <- rep(as.numeric(NA), length(tAll))
            y2[tAll %in% snd$t] <- ch1
            data[[length(data)+1]] <- y2
            names(data)[length(data)] <- "Sound"
        } else if (snd$nChannels == 2) {
            ch1 <- snd$sig[, 1] + 1
            ch2 <-  snd$sig[, 2] - 1

            y2 <- rep(as.numeric(NA), length(tAll))
            y2[tAll %in% snd$t] <- ch1
            data[[length(data)+1]] <- y2
            names(data)[length(data)] <- "Sound1"
            y2 <- rep(as.numeric(NA), length(tAll))
            y2[tAll %in% snd$t] <- ch2
            data[[length(data)+1]] <- y2
            names(data)[length(data)] <- "Sound2"
        } else {
            stop("Only 1 or 2 channels are supported.")
        }
    }

    if (group != "") {  # dygraphs plot-synchronization group
        g <- dygraphs::dygraph(data, group = group, xlab = "Time (sec)")
    } else {
        g <- dygraphs::dygraph(data, xlab = "Time (sec)")
    }

    if (!is.null(snd)) {
        if (snd$nChannels == 1) {
            g <- dygraphs::dyAxis(g, "y2", label = "Sound", independentTicks = TRUE, valueRange = c(-1, 1), drawGrid = FALSE)
            g <- dygraphs::dySeries(g, "Sound", axis = "y2")
        } else if (snd$nChannels == 2) {
            g <- dygraphs::dyAxis(g, "y2", label = "Sound", independentTicks = TRUE, valueRange = c(-2, 2), drawGrid = FALSE)
            g <- dygraphs::dySeries(g, "Sound1", axis = "y2")
            g <- dygraphs::dySeries(g, "Sound2", axis = "y2")
        }
    }

    g <- dygraphs::dySeries(g, "IntensityTier", drawPoints = TRUE, pointSize = 2, strokeWidth = 0, color = "green")
    g <- dygraphs::dyRangeSelector(g, dateWindow = c(it$tmin, it$tmax), fillColor = "")

    g <- dygraphs::dyAxis(g, "x", valueFormatter = "function(d){return d.toFixed(3)}")
    g
}


#' it.interpolate
#'
#' Interpolates IntensityTier contour in given time instances.
#'
#'  a) If \code{t < min(it$t}) (or \code{t > max(it$t)}), returns the first (or the last) value of \code{it$i}.
#'  b) If \code{t} is existing point in \code{it$t}, returns the respective \code{it$f}.
#'  c) If \code{t} is between two existing points, returns linear interpolation of these two points.
#'
#' @param it IntensityTier object
#' @param t vector of time instances of interest
#'
#' @return IntensityTier object
#' @export
#' @seealso \code{\link{it.getPointIndexNearestTime}}, \code{\link{it.read}}, \code{\link{it.write}}, \code{\link{it.plot}}, \code{\link{it.cut}}, \code{\link{it.cut0}}, \code{\link{it.legendre}}
#'
#' @examples
#' it <- it.sample()
#' it2 <- it.interpolate(it, seq(it$t[1], it$t[length(it$t)], by = 0.001))
#' \dontrun{
#' it.plot(it)
#' it.plot(it2)
#' }
it.interpolate <- function(it, t) {
    if (!("numeric" %in% class(t)) &  !("integer" %in% class(t))) {
        stop("t must be numeric vector")
    }

    if (length(it$t) != length(it$i))
        stop("IntensityTier does not have equal length vectors $t and $i")

    if (length(it$t) < 1)
        return(NA)

    if (!identical(sort(it$t), it$t)) {
        stop("time instances $t in IntensityTier are not increasingly sorted")
    }

    if (!identical(unique(it$t), it$t)) {
        stop("duplicated time instances in $t vector of the IntensityTier")
    }

    it2 <- it
    it2$t <- t

    i <- numeric(length(t))
    for (I in seq_along(t)) {
        if (length(it$t) == 1) {
            i[I] <- it$i[1]
        } else if (t[I] < it$t[1]) {   # a)
            i[I] <- it$i[1]
        } else if (t[I] > it$t[length(it$t)]) {   # a)
            i[I] <- it$i[length(it$t)]
        } else {
            # b)
            ind <- which(it$t == t[I])
            if (length(ind) == 1) {
                i[I] <- it$i[ind]
            } else {
                # c)
                ind2 <- which(it$t > t[I]); ind2 <- ind2[1]
                ind1 <- ind2 - 1
                # y = ax + b;  a = (y2-y1)/(x2-x1);  b = y1 - ax1
                a <- (it$i[ind2] - it$i[ind1]) / (it$t[ind2] - it$t[ind1])
                b <- it$i[ind1] - a*it$t[ind1]
                i[I] <- a*t[I] + b
            }
        }
    }

    it2$i <- i
    return(it2)
}


#' it.legendre
#'
#' Interpolate the IntensityTier in \code{npoints} equidistant points and approximate it by Legendre polynomials
#'
#' @param it IntensityTier object
#' @param npoints Number of points of IntensityTier interpolation
#' @param npolynomials Number of polynomials to be used for Legendre modelling
#'
#' @return Vector of Legendre polynomials coefficients
#' @export
#' @seealso \code{\link{it.legendreSynth}}, \code{\link{it.legendreDemo}}, \code{\link{it.cut}}, \code{\link{it.cut0}}, \code{\link{it.read}}, \code{\link{it.plot}}, \code{\link{it.interpolate}}
#'
#' @examples
#' it <- it.sample()
#' it <- it.cut(it, tStart = 0.2, tEnd = 0.4)  # cut IntensityTier and preserve time
#' c <- it.legendre(it)
#' print(c)
#' leg <- it.legendreSynth(c)
#' itLeg <- it
#' itLeg$t <- seq(itLeg$tmin, itLeg$tmax, length.out = length(leg))
#' itLeg$i <- leg
#' \dontrun{
#' plot(it$t, it$i, xlab = "Time (sec)", ylab = "Intensity (dB)")
#' lines(itLeg$t, itLeg$i, col = "blue")
#' }
it.legendre <- function(it, npoints = 1000, npolynomials = 4) {
    if (!isInt(npoints) | npoints < 0) {
        stop("npoints must be integer >= 0.")
    }

    if (!isInt(npolynomials) | npolynomials <= 0) {
        stop("npolynomials must be integer > 0.")
    }

    it <- it.interpolate(it, seq(it$tmin, it$tmax, length.out = npoints))

    y <- it$i


    lP <- npoints # number of points to interpolate the polynomial
    nP <- npolynomials

    B <- matrix(nrow = nP, ncol = lP)  # báze
    x <- seq(-1, 1, length.out = lP)

    for (i in seqM(1, nP)) {
        n <- i - 1
        p <- numeric(lP)
        for (k in seqM(0, n)) {
            p <- p + x^k*choose(n, k)*choose((n+k-1)/2, n)
        }
        p <- p*2^n

        B[i, ] <- p
    }

    c <- numeric(nP)
    for (I in 1: nP) {
        c[I] <- t(matrix(y)) %*% matrix(B[I, ], nrow = lP, ncol = 1) / lP * ((I-1)*2+1)
        # coefficient ((I-1)*2+1) corresponds to power of components, and can also be calculated this way: mean((P.^2).')
    }

    return(c)
}

#' it.legendreSynth
#'
#' Synthetize the contour from vector of Legendre polynomials \code{c} in \code{npoints} equidistant points
#'
#' @param c Vector of Legendre polynomials coefficients
#' @param npoints Number of points of IntensityTier interpolation
#'
#' @return Vector of values of synthetized contour
#' @export
#' @seealso \code{\link{it.legendre}}, \code{\link{it.legendreDemo}}, \code{\link{it.read}}, \code{\link{it.plot}}, \code{\link{it.interpolate}}
#'
#' @examples
#' it <- it.sample()
#' it <- it.cut(it, tStart = 0.2, tEnd = 0.4)  # cut IntensityTier and preserve time
#' c <- it.legendre(it)
#' print(c)
#' leg <- it.legendreSynth(c)
#' itLeg <- it
#' itLeg$t <- seq(itLeg$tmin, itLeg$tmax, length.out = length(leg))
#' itLeg$i <- leg
#' \dontrun{
#' plot(it$t, it$i, xlab = "Time (sec)", ylab = "Intensity (dB)")
#' lines(itLeg$t, itLeg$i, col = "blue")
#' }
it.legendreSynth <- function(c, npoints = 1000) {
    if (!("numeric" %in% class(c)) &  !("integer" %in% class(c))) {
        stop("c must be numeric vector")
    }

    if (!isInt(npoints) | npoints < 0) {
        stop("npoints must be integer >= 0.")
    }

    lP <- npoints # number of points to interpolate the polynomial
    nP <- length(c)

    B <- matrix(nrow = nP, ncol = lP)  # basis
    x <- seq(-1, 1, length.out = lP)

    for (i in seqM(1, nP)) {
        n <- i - 1
        p <- numeric(lP)
        for (k in seqM(0, n)) {
            p <- p + x^k*choose(n, k)*choose((n+k-1)/2, n)
        }
        p <- p*2^n

        B[i, ] <- p
    }

    if (nP > 0) {
        yModelovane <- t(matrix(c)) %*% B
    }
    else {
        yModelovane <- rep(NA, npoints)
    }

    return(as.numeric(yModelovane))
}

#' it.legendreDemo
#'
#' Plots first four Legendre polynomials
#'
#' @export
#' @seealso \code{\link{it.legendre}}, \code{\link{it.legendreSynth}}, \code{\link{it.read}}, \code{\link{it.plot}}, \code{\link{it.interpolate}}
#'
#' @examples
#' \dontrun{
#' it.legendreDemo()
#' }
it.legendreDemo <- function() {
    graphics::par(mfrow = c(2, 2))
    graphics::plot(it.legendreSynth(c(1, 0, 0, 0), 1024))
    graphics::plot(it.legendreSynth(c(0, 1, 0, 0), 1024))
    graphics::plot(it.legendreSynth(c(0, 0, 1, 0), 1024))
    graphics::plot(it.legendreSynth(c(0, 0, 0, 1), 1024))
    graphics::par(mfrow = c(1, 1))
}



#' it.cut
#'
#' Cut the specified interval from the IntensityTier and preserve time
#'
#' @param it IntensityTier object
#' @param tStart beginning time of interval to be cut (default \code{-Inf} = cut from the \code{tmin} of the IntensityTier)
#' @param tEnd final time of interval to be cut (default \code{Inf} = cut to the \code{tmax} of the IntensityTier)
#'
#' @return IntensityTier object
#' @export
#' @seealso \code{\link{it.cut0}}, \code{\link{it.read}}, \code{\link{it.plot}}, \code{\link{it.interpolate}}, \code{\link{it.legendre}}, \code{\link{it.legendreSynth}}, \code{\link{it.legendreDemo}}
#'
#' @examples
#' it <- it.sample()
#' it2 <-   it.cut(it,  tStart = 0.3)
#' it2_0 <- it.cut0(it, tStart = 0.3)
#' it3 <-   it.cut(it,  tStart = 0.2, tEnd = 0.3)
#' it3_0 <- it.cut0(it, tStart = 0.2, tEnd = 0.3)
#' it4 <-   it.cut(it,  tEnd = 0.3)
#' it4_0 <- it.cut0(it, tEnd = 0.3)
#' it5 <-   it.cut(it,  tStart = -1, tEnd = 1)
#' it5_0 <- it.cut0(it, tStart = -1, tEnd = 1)
#' \dontrun{
#' it.plot(it)
#' it.plot(it2)
#' it.plot(it2_0)
#' it.plot(it3)
#' it.plot(it3_0)
#' it.plot(it4)
#' it.plot(it4_0)
#' it.plot(it5)
#' it.plot(it5_0)
#' }
it.cut <- function(it, tStart = -Inf, tEnd = Inf) {
    if (!isNum(tStart)) {
        stop("tStart must be a number.")
    }
    if (!isNum(tEnd)) {
        stop("tEnd must be a number.")
    }
    if (is.infinite(tStart) & tStart>0) {
        stop("infinite tStart can be negative only")
    }
    if (is.infinite(tEnd) & tEnd<0) {
        stop("infinite tEnd can be positive only")
    }
    if (tEnd < tStart) {
        stop("tEnd must be >= tStart")
    }

    it2 <- it
    it2$t <- it$t[it$t >= tStart  &  it$t <= tEnd]
    it2$i <- it$i[it$t >= tStart  &  it$t <= tEnd]

    if (is.infinite(tStart)) {
        it2$tmin <- it$tmin
    } else {
        it2$tmin <- tStart
    }

    if (is.infinite(tEnd)) {
        it2$tmax <- it$tmax
    } else {
        it2$tmax <- tEnd
    }

    return(it2)
}

#' it.cut0
#'
#' Cut the specified interval from the IntensityTier and shift time so that the new \code{tmin} = 0
#'
#' @param it IntensityTier object
#' @param tStart beginning time of interval to be cut (default \code{-Inf} = cut from the \code{tmin} of the IntensityTier)
#' @param tEnd final time of interval to be cut (default \code{Inf} = cut to the \code{tmax} of the IntensityTier)
#'
#' @return IntensityTier object
#' @export
#' @seealso \code{\link{it.cut}}, \code{\link{it.read}}, \code{\link{it.plot}}, \code{\link{it.interpolate}}, \code{\link{it.legendre}}, \code{\link{it.legendreSynth}}, \code{\link{it.legendreDemo}}
#'
#' @examples
#' it <- it.sample()
#' it2 <-   it.cut(it,  tStart = 0.3)
#' it2_0 <- it.cut0(it, tStart = 0.3)
#' it3 <-   it.cut(it,  tStart = 0.2, tEnd = 0.3)
#' it3_0 <- it.cut0(it, tStart = 0.2, tEnd = 0.3)
#' it4 <-   it.cut(it,  tEnd = 0.3)
#' it4_0 <- it.cut0(it, tEnd = 0.3)
#' it5 <-   it.cut(it,  tStart = -1, tEnd = 1)
#' it5_0 <- it.cut0(it, tStart = -1, tEnd = 1)
#' \dontrun{
#' it.plot(it)
#' it.plot(it2)
#' it.plot(it2_0)
#' it.plot(it3)
#' it.plot(it3_0)
#' it.plot(it4)
#' it.plot(it4_0)
#' it.plot(it5)
#' it.plot(it5_0)
#' }
it.cut0 <- function(it, tStart = -Inf, tEnd = Inf) {
    if (!isNum(tStart)) {
        stop("tStart must be a number.")
    }
    if (!isNum(tEnd)) {
        stop("tEnd must be a number.")
    }
    if (is.infinite(tStart) & tStart>0) {
        stop("infinite tStart can be negative only")
    }
    if (is.infinite(tEnd) & tEnd<0) {
        stop("infinite tEnd can be positive only")
    }
    if (tEnd < tStart) {
        stop("tEnd must be >= tStart")
    }

    it2 <- it
    it2$t <- it$t[it$t >= tStart  &  it$t <= tEnd]
    it2$i <- it$i[it$t >= tStart  &  it$t <= tEnd]

    if (is.infinite(tStart)) {
        it2$tmin <- it$tmin
    } else {
        it2$tmin <- tStart
    }

    if (is.infinite(tEnd)) {
        it2$tmax <- it$tmax
    } else {
        it2$tmax <- tEnd
    }

    it2$t <- it2$t - it2$tmin
    it2$tmax <- it2$tmax - it2$tmin
    it2$tmin <- 0

    return(it2)
}

#' as.it
#'
#' Renames the \code{class(it)["name"]} attribute and sets \code{class(it)["type"] <- "IntensityTier"} (if it is not already set)
#'
#' @param it IntensityTier object
#' @param name New name
#'
#' @return IntensityTier object
#' @export
#'
#' @examples
#' class(it.sample())
#' class(as.it(it.sample(), name = "New Name"))
as.it <- function(it, name = "") {
    class(it)["type"] <- "IntensityTier"
    class(it)["name"] <- name
    return(it)
}



#' it.getPointIndexHigherThanTime
#'
#' Returns index of point which is nearest the given time from right, i.e.
#' \code{time} <= pointTime.
#'
#' @param it IntensityTier object
#' @param time time which is going to be found in points
#'
#' @return integer
#' @export
#' @seealso \code{\link{it.getPointIndexNearestTime}}, \code{\link{it.getPointIndexLowerThanTime}}
#'
#' @examples
#' it <- it.sample()
#' it.getPointIndexHigherThanTime(it, 0.5)
it.getPointIndexHigherThanTime <- function(it, time) {
    if (!isNum(time)) {
        stop("Time must be a number.")
    }

    ind <- NA

    npoints <- length(it$t)
    for (I in seqM(1, npoints)) {
        if (time <= it$t[I]) {
            ind <- I
            break
        }
    }


    return(ind)
}




#' it.getPointIndexLowerThanTime
#'
#' Returns index of point which is nearest the given time from left, i.e.
#' pointTime <= \code{time}.
#'
#' @param it IntensityTier object
#' @param time time which is going to be found in points
#'
#' @return integer
#' @export
#' @seealso \code{\link{it.getPointIndexNearestTime}}, \code{\link{it.getPointIndexHigherThanTime}}
#'
#' @examples
#' it <- it.sample()
#' it.getPointIndexLowerThanTime(it, 0.5)
it.getPointIndexLowerThanTime <- function(it, time) {
    if (!isNum(time)) {
        stop("Time must be a number.")
    }

    ind <- NA

    npoints <- length(it$t)
    for (I in seqM(npoints, 1, by = -1)) {
        if (time >= it$t[I]) {
            ind <- I
            break
        }
    }


    return(ind)
}




#' it.getPointIndexNearestTime
#'
#' Returns index of point which is nearest the given \code{time} (from both sides).
#'
#' @param it IntensityTier object
#' @param time time which is going to be found in points
#'
#' @return integer
#' @export
#' @seealso \code{\link{it.getPointIndexLowerThanTime}}, \code{\link{it.getPointIndexHigherThanTime}}
#'
#' @examples
#' it <- it.sample()
#' it.getPointIndexNearestTime(it, 0.5)
it.getPointIndexNearestTime <- function(it, time) {
    if (!isNum(time)) {
        stop("Time must be a number.")
    }

    ind <- NA

    npoints <- length(it$t)
    minDist <- Inf
    minInd <- NA

    for (I in seqM(1, npoints)) {
        dist <- abs(it$t[I] - time)
        if (dist < minDist) {
            minDist <- dist
            minInd <- I
        }
    }

    ind <- minInd


    return(ind)
}

Try the rPraat package in your browser

Any scripts or data that you put into this service are public.

rPraat documentation built on Feb. 28, 2021, 1:06 a.m.