R/transformations.R

In linea: Linear Regression Interface

#' decay
#'
#' Time series decay
#'
#' Applies the specified decay on the input vector, v
#'
#' @param v numeric vector
#' @param decay The rate of decay as a numeric decimal
#' @export
#' @return The transformed vector \code{v}
#' @examples
#' decay(c(1,0,0,0,1,0,0,0,2), 0.5)
#' decay(c(1,0,0,0,1,0,0,0,2), 0.1)
decay = function(v,decay){
  if (decay == 0) {
    return(v)
  }
  else {
    stats::filter(v, decay, method = "recursive")
  }
}

#' hill_function
#'
#' Hill Function
#'
#' Applies the Hill Function 1 - (k^m)(k^m + v^m) on the input vector, v
#'
#' @param v Numeric vector
#' @param m Numeric integer or decimal
#' @param k Numeric integer or decimal
#' @param abs Boolean to determine if diminishing scale \code{m} is a percentage or absolute value
#' @export
#' @return The transformed vector \code{v}
#' @examples
#' hill_function(c(1,0,0,0,10,0,0,0,20), k=10)
#' hill_function(c(1,0,0,0,10,0,0,0,20), k=0.1, abs = FALSE)
#' hill_function(c(1,0,0,0,10,0,0,0,20), k=10, m = 3)
hill_function = function(v,k = 1,m = 5,abs = TRUE){
  if (k == 0) {
    return(v)
  }
  if (!abs) {
    k = k*max(v)
  }
  return(1-((k^m))/((k^m)+(v^m)))
}


#' Diminish
#'
#' Negative exponential (Diminish returns)
#'
#' Applies the negative exponential (1 - exp(-x/m)) on the input vector, v
#'
#' @param v Numeric vector
#' @param m Scale of diminishing as a numeric integer or decimal
#' @param abs Boolean to determine if diminishing scale \code{m} is a percentage or absolute value
#' @export
#' @return The transformed vector \code{v}
#' @examples
#' diminish(c(1,0,0,0,1,0,0,0,2), 1)
#' diminish(c(1,0,0,0,1,0,0,0,2), 1, FALSE)
diminish = function(v,m,abs = TRUE){
  m = as.numeric(as.character(m))
  if (m == 0) {
    return(v)
  }
  if (!abs) {
    m = m*max(v)
  }
  return(1 - base::exp(-v/m))
}

#' Lag
#'
#' Lag by \code{l}
#'
#' Applies a lag of \code{l} on the input vector, v
#'
#' @param v Numeric vector
#' @param l Lag as an integer
#' @param strategy string to determine the NAs generated by the lag should be filled with zeros or with the extremities' values
#' @export
#' @return The lagged vector \code{v}
#' @examples
#' lag(c(1,0,0,0,1,0,0,0,2), 1)
#' lag(c(1,0,0,0,1,0,0,0,2), -2)
#' lag(c(1,0,0,0,1,0,0,0,2), -2, strategy = 'zero')
lag = function(v,l,strategy = 'extremes'){

  # if lag is zero, return original vector
  if(l == 0){
    return(v)
  }

  # get the length of the vector
  n = length(v)

  # if the lag is positive
  if(l > 0){

    #move forward

    # cut forward extremities
    v = v[1:(n-l)]

    # if zero is TRUE
    if(strategy == 'zero'){

      v = c(rep(0,l),v)

    }else if(strategy == 'extremes'){

      v = c(rep(v[1],l),v)

    }
  }
  if(l < 0){

    l = l*-1

    v = v[(l+1):n]

    if(strategy == 'zero'){

      v = c(v,rep(0,l))

    }
    else if(strategy == 'extremes'){

      v = c(v,rep(v[length(v)],l))

    }
  }

  return(v)

}

#' MA
#'
#' Moving Average
#'
#' Applies a moving average on the input vector. The type of moving average is defined by the argument \code{align}.
#'
#' @param v Numeric vector
#' @param width Width of moving average window as an integer, v
#' @param align Either string "center", "left", or "right"
#' @param zero Boolean to determine the NAs generated by the moving average should be filled with zeros or with the vector's mean.
#' @importFrom zoo rollmean
#' @export
#' @return The modified vector \code{v}
#' @examples
#' ma(c(1,0,0,0,1,0,0,0,2), 3)
#' ma(c(1,0,0,0,1,0,0,0,2), 3, align = "right")
#' ma(c(1,0,0,0,1,0,0,0,2), 3, zero = FALSE)
ma = function(v,width,align="center",zero=TRUE){

  if(width == 0){
    return(v)
  }else{

    if(zero){
      v = rollmean(v,width,fill = 0,align = align)
    }else{
      v = rollmean(v,width,fill = mean(v),align = align)
    }
  }

  return(v)
}

#' trans_tester
#'
#' Transformation Tester
#'
#' Tests a mathematical transformation function for errors.
#' The function must accept an input vector \code{v} as well as, optionally, additional parameters.
#'
#' @param f the function to test
#' @param p an optional \code{list} of parameters and values
#' @export
#' @returns a character vector of messages
#' @examples
#' trans_test(log)
trans_test = function(f,p = NULL){
  messages = c()
  if(is.null(p)){
    # zero test
    x = f(0) %>% TRY()
    if (is.null(x)) {
      messages = c(messages,('The function failed the  zero test.'))
    } else if (!is.numeric(x)) {
      messages = c(messages,('The function returned a non-numeric value for test  zero'))
    } else if (is.infinite(x)) {
      messages = c(messages,('The function returned a Infinite value for test  zero'))
    } else if (is.na(x)) {
      messages = c(messages,('The function returned a NA value for test  zero'))
    }

    # 0.1 test
    x = f(0.1) %>% TRY()
    if (is.null(x)) {
      messages = c(messages,('The function failed the 0.1 test.'))
    } else if (!is.numeric(x)) {
      messages = c(messages,('The function returned a non-numeric value for the 0.1 test.'))
    } else if (is.infinite(x)) {
      messages = c(messages,('The function returned a Infinite value for test  0.1'))
    } else if (is.na(x)) {
      messages = c(messages,('The function returned a NA value for test  0.1'))
    }

    # -0.1 test
    x = f(-0.1) %>% TRY()
    if (is.null(x)) {
      messages = c(messages,('The function failed the -0.1 test.'))
    } else if (!is.numeric(x)) {
      messages = c(messages,('The function returned a non-numeric value for the -0.1 test.'))
    } else if (is.infinite(x)) {
      messages = c(messages,('The function returned a Infinite value for test  -0.1'))
    } else if (is.na(x)) {
      messages = c(messages,('The function returned a NA value for test  -0.1'))
    }

    # 1 test
    x = f(1) %>% TRY()
    if (is.null(x)) {
      messages = c(messages,('The function failed the 1 test.'))
    } else if (!is.numeric(x)) {
      messages = c(messages,('The function returned a non-numeric value for the 1 test.'))
    } else if (is.infinite(x)) {
      messages = c(messages,('The function returned a Infinite value for test  1'))
    } else if (is.na(x)) {
      messages = c(messages,('The function returned a NA value for test  1'))
    }

    # -1 test
    x = f(-1) %>% TRY()
    if (is.null(x)) {
      messages = c(messages,('The function failed the -1 test.'))
    } else if (!is.numeric(x)) {
      messages = c(messages,('The function returned a non-numeric value for the -1 test.'))
    } else if (is.infinite(x)) {
      messages = c(messages,('The function returned a Infinite value for test  -1'))
    } else if (is.na(x)) {
      messages = c(messages,('The function returned a NA value for test  -1'))
    }

    # 1000 test
    x = f(1000) %>% TRY()
    if (is.null(x)) {
      messages = c(messages,('The function failed the 1000 test.'))
    } else if (!is.numeric(x)) {
      messages = c(messages,('The function returned a non-numeric value for the 1000 test.'))
    } else if (is.infinite(x)) {
      messages = c(messages,('The function returned a Infinite value for test  1000'))
    } else if (is.na(x)) {
      messages = c(messages,('The function returned a NA value for test  1000'))
    }

    # -1000 test
    x = f(-1000) %>% TRY()
    if (is.null(x)) {
      messages = c(messages,('The function failed the -1000 test.'))
    } else if (!is.numeric(x)) {
      messages = c(messages,('The function returned a non-numeric value for the -1000 test.'))
    } else if (is.infinite(x)) {
      messages = c(messages,('The function returned a Infinite value for test -1000'))
    } else if (is.na(x)) {
      messages = c(messages,('The function returned a NA value for test  -1000'))
    }
  }
  return(messages)
}