R/functions_smooth_derive.r

In ccamp83/kinesis: R package for the analysis of motion trajectories and movement kinematics

# functions to smooth, derive and rescale kinematics
# they exploit built-in r functions, to be applied with ddply

# kin.smooth ----
#' smooth data points.
#' @param x: predictor
#' @param  y: variable to be smoothed
#' @param  l: lambda - smoothing parameter (default to .2)
#' @export
kin.smooth <- function(x,y,l=.2){
  fit <- sreg(x, y, lambda=l)
  return(predict(fit, x))
}

# kin.derive ----
#' smooth then calculate derivatives of a given variable with respect to a specific predictor. Inputs:
#' @param x: predictor
#' @param y: variable to be smoothed
#' @param l: lambda - smoothing parameter (default to .2)
#' @param d: order of derivative
#' @export
kin.derive <- function(x,y,l=.2,d){predict(sreg(x,y,lambda=l), deriv=d)[match(x,sreg(x,y, lambda=l)$x)]}

# kin.rescale ----
#' rescale the values of a vector within a specified range. Inputs:
#' @param x: vector to be rescaled
#' @param a: range minimum
#' @param b: range maximum
#' @export
kin.rescale <- function(x,a,b) {
  rg <- c(a,b)
  rescale(x, to = rg, from = range(x, na.rm = TRUE)) }

# kin.smooth.repair ----
#' @export
kin.smooth.repair <- function(x, y.raw, lam = 1e-18, maxFrames = 18, fingersOccluded, framesOccluded)
{
  y.raw[which(fingersOccluded==1)] <- NA

  # assign lam temporary in the global environment (temporarily)
  assign("lam", lam, envir = .GlobalEnv)

  if(any(is.na(y.raw)))
  {
    # which rows contain NAs?
    missing.frames <- attr(na.omit(y.raw), "na.action")

    fit <- sreg(x[-missing.frames], na.omit(y.raw),lambda=lam)

    occluded.frames.check <- data.frame(
      f = (fingersOccluded*x)[fingersOccluded*x != 0]
      ,
      occluded = (fingersOccluded*framesOccluded)[fingersOccluded*framesOccluded != 0]
    )
    occluded.frames.check$group <- with(occluded.frames.check, c(0, cumsum(diff(f) != 1)))

    # assign maxFrames temporarily to the global environment
    assign("maxFrames", maxFrames, envir = .GlobalEnv)

    occluded.frames.check <- ddply(occluded.frames.check, .(group), mutate,
                                   repairable = ifelse(max(occluded) <= maxFrames, 'repair', 'discard'))

    frames.to.interpolate <- match(occluded.frames.check$f[occluded.frames.check$repairable=='repair'], x)

    y <- predict(fit, x) * ifelse(fingersOccluded == 1, NA, 1)
    y[frames.to.interpolate] <- predict(fit, x[frames.to.interpolate])

    # remove maxFrames from global environment
    remove(maxFrames, envir = .GlobalEnv)
    # remove lam from global environment
    remove(lam, envir = .GlobalEnv)

    return(y)

  }else
  {
    fit <- sreg(x, y.raw,lambda=lam)
    y <- predict(fit, x)

    # remove lam from the global environment
    remove(lam, envir = .GlobalEnv)

    return(y)
  }
}

# kin.signal.repair ----
#' @export
kin.signal.repair <- function(y.raw, maxFrames = 18)
{
  # first check if the signal needs to be assessed
  # are there NAs?
  na.detected <- any(is.na(y.raw))
  # if not, check the signal
  if(!na.detected)
  {
    y.raw <- kin.signal.missing(y.raw)
    na.detected <- any(is.na(y.raw))
  }
  # if yes, analyze the signal
  if(na.detected)
  {
    cat("Reconstructing missing data...")

    # which positions contain NAs?
    missing.frames <- which(is.na(y.raw))

    # flag the NAs in the vector
    y.raw.flag.na <- ifelse(is.na(y.raw), 1, 0)
    # cumulative count of NAs
    y.raw.flag.na.count <- y.raw.flag.na * unlist(lapply(rle(y.raw.flag.na)$lengths, seq_len))

    # create predictor
    x <- 1:length(y.raw)

    # fit the signal without NAs
    fit <- fields::sreg(x[-missing.frames], na.omit(y.raw),lambda=1e-18)

    # gather all missing data in groups
    missing.frames.check <- data.frame(
      missing.frames
      ,
      count = y.raw.flag.na.count[y.raw.flag.na.count!=0]
    )
    missing.frames.check$group <- with(missing.frames.check, c(0, cumsum(diff(count) != 1)))

    # group-by-group decide whether to repair
    assign("maxFrames", maxFrames, envir = .GlobalEnv) # assign maxFrames temporarily to the global environment
    missing.frames.check <- ddply(missing.frames.check, .(group), mutate,
                                  decision = ifelse(max(count) <= maxFrames, 'repair', 'discard'))

    # extract frames for interpolation
    frames.to.interpolate <- match(missing.frames.check$missing.frames[missing.frames.check$decision=='repair'], x)

    # repair the signal
    y <- y.raw
    y[frames.to.interpolate] <- predict(fit, x[frames.to.interpolate])

    # remove maxFrames from global environment
    remove(maxFrames, envir = .GlobalEnv)

    cat("Done.\n")
    return(y)

  } else
  {
    cat("Signal looks good.\n")
    return(y.raw)
  }
}