R/as.pulse.R

In DecomposeR: Empirical Mode Decomposition for Cyclostratigraphy

#' @title Create / Check pulse objects
#'
#' @description Allows to convert instantaneous frequency determination results
#' into a single 'pulse' object. This is the format generated by inst.pulse
#' (and gzc if \code{output = 2})
#'
#' @param dt a vector of length n for the depth or time reference
#' @param f a data.frame or matrix of n rows of the instantaneous frequencies
#' @param a a data.frame or matrix of n rows of the instantaneous amplitudes
#' @param m a data.frame or matrix of n rows of the components from which the
#' frequencies and amplitudes were computed from
#' @param idt data.frame or matrix of n rows of identity tuning: new dt
#' coordinates to remove the frequency modulation
#' @param mode the mode sequence index to give to each replicated IMFs
#' @param repl a vector for the number of replicates or a matrix,
#' indicating in which replicate set each point is
#' @param order the order of the imf, typically from higher frequency to lower
#' frequency
#' @param pulse a pulse object to check
#'
#' @return a list made of $dt (depth/time), $f (instantaneous frequency),
#' $a (instantaneous amplitude) if a is provided, $repl (the replicate id of
#' each point) and $mode (the mode id of each point).
#'
#' @examples
#' set.seed(42)
#'
#' n <- 600
#' dt <- seq_len(n)
#'
#' p1 <- 30
#' p2 <- 240
#'
#' s30  <- (1 + 0.6 * sin(dt*2*pi/p2)) * sin(dt*2*pi/p1)
#' s240 <- 2 * sin(dt*2*pi/p2)
#'
#' xy <- s30 + s240
#'
#' dec <- as.emd(xy = xy, dt = dt, imf = matrix(c(s30, s240), ncol = 2))
#'
#' plot_emd(dec, pdf = FALSE, style = 1)
#'
#' pulse <- inst.pulse(dec, last = TRUE, breaks = 200, bins = 40, cut = 10)
#'
#' is.pulse(pulse)
#'
#' simp.pulse <- as.pulse(pulse$dt, pulse$f)
#'
#' str(simp.pulse)
#'
#' @export

as.pulse <- function(dt, f, a = NULL, m = NULL, idt = NULL,
                     mode = NULL, repl = 1, order = NA)
{

  ldt <- length(dt)

  f <- as.matrix(f)

  if(ldt != nrow(f)) {
    stop("The 'f' parameter should be a matrix of n rows")
  }

  nc <- ncol(f)

  if(!(is.na(order[[1]]) & length(order) == 1) &
     length(order) == nc & is.numeric(order)) f <- f[,order]

  repl  <- unique(as.vector(repl))
  repln <- length(repl)

  if(!is.null(m)){

    m <- as.matrix(m)

    if(!all(dim(m) == dim(f))){
      stop("If provided, 'm' should be a matrix of same dimensions than f")
    }

    if(!(inherits(m[1,1], "numeric") | inherits(m[1,1], "integer"))){
      stop("If provided, 'm' should be of class numeric or integer")
    }

  }

  if(!is.null(idt)){

    idt <- as.matrix(idt)

    if(!all(dim(idt) == dim(f))){
      stop("If provided, 'idt' should be a matrix of same dimensions than f")
    }

    if(!(inherits(idt[1,1], "numeric") | inherits(idt[1,1], "integer"))){
      stop("If provided, 'idt' should be of class numeric or integer")
    }

  }

  if(!is.null(mode)){

    if(length(mode) != nc/repln) {
      stop("'mode' should have ", nc/repl, " elements")
    }

    if(!(inherits(mode, "numeric") | inherits(mode, "integer"))){
      stop("'mode' should be of class numeric or integer")
    }

    mode <- matrix(rep(mode, repln * nrow(f)),
                   ncol = ncol(f), byrow = T)

  } else {
    mode <- matrix(rep(seq_len(nc/repln), repln * nrow(f)),
                   ncol = nc, byrow = T)
  }

  reps <- matrix(rep(rep(repl, each = nc/repln), ldt),
                 nrow = ldt, byrow = T)

  if(!is.null(a)){

    a <- as.matrix(a)

    if(!all(dim(a) == dim(f))){
      stop("If provided, 'a' should be a matrix of same dimensions than f")
    }

    if(!(inherits(a[1,1], "numeric") | inherits(a[1,1], "integer"))){
      stop("If provided, 'a' should be of class numeric or integer")
    }

  }

  res <- list(dt = dt, m = m, f = f, a = a , idt= idt,
               repl = reps, mode = mode)

  rem <- NULL

  if(is.null(m)) rem <- c(rem, 2)
  if(is.null(a)) rem <- c(rem, 4)
  if(is.null(idt)) rem <- c(rem, 5)

  if(!is.null(rem)) res <- res[-rem]

  return(res)

}

#' @rdname as.pulse
#' @export

is.pulse <- function(pulse)
{

  name <- deparse(substitute(pulse))

  if(!all(c("dt", "f", "repl", "mode") %in% names(pulse))){
    warning("The pulse object should have $dt, $f, $repl and $mode elements")
    return(F)
  }

  res <- T

  tc1 <- inherits(pulse$dt, "numeric") | inherits(pulse$dt, "integer")

  if(!tc1) {
    warning(name, "$dt should be of class numeric or integer")
    res <- F
  }

  tc2 <- inherits(pulse$f, "matrix")
  tc3 <- inherits(pulse$repl,"matrix")
  tc4 <- inherits(pulse$mode, "matrix")

  if(!(tc2 & tc3 & tc4)) {
    warning(name, "$f, ", name, "$repl & ", name,
            "$mode should be of class matrix")
    res <- F
  }

  ldt <- length(pulse$dt)

  nr <- length(unique(pulse$repl[1,]))
  nm <- length(unique(pulse$mode[1,]))

  df    <- dim(pulse$f)
  drepl <- dim(pulse$repl)
  dmode <- dim(pulse$mode)

  tl1 <- df[1] == ldt
  tl2 <- drepl[1] == ldt
  tl3 <- dmode[1] == ldt

  if(!(tl1 & tl2 & tl3)) {
    warning(name, "$f,  ", name, "$repl & ", name, "$mode should have as many",
            " rows as ", name, "$dt has elements")
    res <- F
  }

  tw1 <- df[2] == nr*nm
  tw2 <- drepl[2] == nr*nm
  tw3 <- dmode[2] == nr*nm

  if(!(tw1 & tw2 & tw3)) {
    warning(name, "$f,  ", name, "$repl & ", name, "$mode should have ", nr*nm,
            " columns, which is the amount of replicates multiplied by the",
            " amount of modes")
    res <- F
  }

  if(!is.null(pulse$a)){

    tc5 <- inherits(pulse$a, "matrix")

    if(!tc5) {
      warning(name, "$a should be of class matrix")
      res <- F
    }

    da    <- dim(pulse$a)

    tl4 <- da[1] == ldt

    if(!tl4) {
      warning(name, "$a should have as many",
              " rows as ", name, "$dt has elements")
      res <- F
    }

    tw4 <- da[2] == nr*nm


    if(!tw4) {
      warning(name, "$a should have ", nr*nm,
              " columns, which is the amount of replicates multiplied by the",
              " amount of modes")
      res <- F
    }

  }

  if(!is.null(pulse$m)){

    tc6 <- inherits(pulse$m, "matrix")

    if(!tc6) {
      warning(name, "$m should be of class matrix")
      res <- F
    }

    dm    <- dim(pulse$m)

    tl5 <- dm[1] == ldt

    if(!tl5) {
      warning(name, "$m should have as many",
              " rows as ", name, "$dt has elements")
      res <- F
    }

    tw5 <- dm[2] == nr*nm


    if(!tw5) {
      warning(name, "$m should have ", nr*nm,
              " columns, which is the amount of replicates multiplied by the",
              " amount of modes")
      res <- F
    }

  }

  if(!is.null(pulse$idt)){

    tc7 <- inherits(pulse$idt, "matrix")

    if(!tc7) {
      warning(name, "$idt should be of class matrix")
      res <- F
    }

    didt    <- dim(pulse$idt)

    tl6 <- didt[1] == ldt

    if(!tl6) {
      warning(name, "$idt should have as many",
              " rows as ", name, "$dt has elements")
      res <- F
    }

    tw6 <- didt[2] == nr*nm


    if(!tw6) {
      warning(name, "$idt should have ", nr*nm,
              " columns, which is the amount of replicates multiplied by the",
              " amount of modes")
      res <- F
    }

  }


  tu1 <- length(unlist(apply(pulse$repl, 2, unique))) == nr*nm
  tu2 <- length(unlist(apply(pulse$mode, 2, unique))) == nr*nm

  if(!(tu1 & tu2)) {
    warning("Each row in ", name, "$repl & ", name, "$mode should be identical")
    res <- F
  }

  sr <- rep(unique(pulse$repl[1,]), each = nm)

  ts1 <- all(pulse$repl[1,] == sr)

  if(!ts1) {
    warning("Each row in ", name, "$repl should be ", paste(sr, collapse = " "))
    res <- F
  }


  sm <- rep(pulse$mode[1,seq_len(nm)], nr)

  ts2 <- all(pulse$mode[1,] == sm)

  if(!ts2) {
    warning("Each row in ", name, "$repl should be a repetition of identical ",
            "mode sequence such as ", sm)
    res <- F
  }

  return(res)

}