R/windowing_functions.R

In craddm/firfiltR: FIR filtering

#' Create windowing function
#'
#' Create a windowing function for use by \code{firws}
#'
#' @param type Window function to apply
#' @param m Filter order
#' @param a alpha/beta to be used for some window functions
#' @keywords internal
select_window <- function(type,
                          m,
                          a = NULL) {

  m <- m + 1
  w <- switch(type,
              "rectangular" = rectangular(m),
              "bartlett" = bartlett(m),
              "hann" = hann(m),
              "hamming" = hamming(m),
              "blackman" = blackman(m),
              "blackmanharris" = blackmanharris(m),
              "kaiser" = kaiser(m),
              "tukey" = tukey(m)
              )
  w
}

#' Rectangular window design
#'
#' @author Andreas Widmann. Ported to R by Matt Craddock \email{matt@@mattcraddock.com}
#' @param m Filter order
#' @keywords internal

rectangular <- function(m) {
  w <- rep(1, m)
  w
}

#' Bartlett window
#' @author Andreas Widmann. Ported to R by Matt Craddock \email{matt@@mattcraddock.com}
#' @param m Filter order
#' @keywords internal
#'
bartlett <- function(m) {
  w <- 1 - abs(seq(-1,
                   1,
                   by = 2 / (m - 1)))
  w
}

#' Hann window
#' @author Andreas Widmann. Ported to R by Matt Craddock \email{matt@@mattcraddock.com}
#' @param m Filter order
#' @keywords internal
hann <- function(m) {
  w <- hamming(m, 0.5)
  w
}

#' Hamming window
#'
#' @author Andreas Widmann. Ported to R by Matt Craddock \email{matt@@mattcraddock.com}
#' @param m Filter order
#' @param a blah
#' @keywords internal
hamming <- function(m,
                    a = 25/46) {
  m <- seq(0,
           1,
           by = 1 / (m - 1))
  w <- a - (1 - a) * cos(2 * pi * m)
  w
}

#' Blackman window
#'
#' @author Andreas Widmann. Ported to R by Matt Craddock \email{matt@@mattcraddock.com}
#' @param m Filter order
#' @param a alpha
#' @keywords internal
blackman <- function(m,
                     a = c(0.42, 0.5, 0.08, 0)) {
  m <- seq(0,
           1,
           by = 1 / (m - 1))
  w <- a[1] - a[2] * cos(2 * pi * m) + a[3] * cos(4 * pi * m) - a[4] * cos(6 * pi * m)
  w
}

#' Blackman-Harris
#'
#' @author Andreas Widmann. Ported to R by Matt Craddock \email{matt@@mattcraddock.com}
#' @param m Filter order
#' @keywords internal
blackmanharris <- function(m) {
  w <- blackman(m,
                c(0.35875,
                  0.48829,
                  0.14128,
                  0.01168))
  w
}

#' Kaiser window
#'
#' @param m Filter order
#' @param a alpha
#'
#' @keywords internal
kaiser <- function(m,
                   a = 0.5) {
  m <- seq(-1,
           1,
           by = 2 / (m - 1))
  w <- besselI(a * sqrt(1 - m ^ 2), 0) / besselI(a, 0)
  w
}

#' Tukey window
#'
#' @author Andreas Widmann. Ported to R by Matt Craddock \email{matt@@mattcraddock.com}
#' @param m Filter order
#' @param a alpha
#' @keywords internal
tukey <- function(m,
                  a = 0.5) {
  if (a <= 0) {

    w <- t(rep(1, m))

  } else if (a >= 1) {
    w <- hann(m)
  } else {
    a <- (m - 1) / 2 * a
    tapArray <- t(seq(0, a, by = 1)) / a
    w <- c(0.5 - 0.5 * cos(pi * tapArray),
          matrix(1, nrow = m - 2 * length(tapArray), ncol = 1),
          0.5 - 0.5 * cos(pi * rev(tapArray)))
    w
  }
}