R/generator.R

In rpatrec: Recognising Visual Charting Patterns in Time Series Data

#'Generate a time series containing a Visual Charting Pattern.
#'
#'This function lets you generate any pattern you specify in the parameters. For known definitions, either
#'check the examples or the vignettes. This is mainly used to test either your own or this smoothing and recognition
#'function.
#'
#'For an overview of the package capabilities, click here \link{rpatrec}
#'
#'@param start Starting value
#'@param dlength Integer. Length of the signal part of the time series
#'@param tot.spread Integer. Difference between the lowest and highest value of the time series
#'@param presig Integer. Length of the pre-signal part of the time series
#'@param postsig Integer. Length of the post-signal part of the time series
#'@param plength No longer needed, kept for compatability. Set to 0.
#'@param parts Vector of Integers. Must be the same length as \code{sprd}
#'    Defines how far the extrema lie apart from another (in percent)
#'    PREVIOUSLY: Vector must contain plength + 2 elements, the first element being 0 and the last 100.
#'@param sprd Vector of Integers. Must be the same length as \code{parts}
#'    Defines the value of the extrema in percent of \code{tot.spread} in relation to \code{start}.
#'    PREVIOUSLY: Vector must contain plength + 2 elements, the first and last elemnt should be 0.
#'
#'@return Time series with (optional) pre- or post signal, and the specified pattern.
#'
#'@examples
#'\dontrun{
#'#create a standard HS pattern:
#'generator()
#'#
#'
#'#create a shifted head and shoulders pattern
#'generator(sprd = c(20,10,90,40,60))
#'#
#'#create a Double Tops pattern
#'generator(plength=3,parts=c(25,50,75),sprd=c(80,40,80))
#'#
#'#create a Rectangle Tops pattern
#'generator(plength=5,parts=c(20,40,50,60,80),sprd=c(80,40,80,40,80))
#'#
#'#create a single peak, 10 data points, max is approximately 10
#'generator(0,10,10,0,0,0,50,100)
#'}
#'
#'@importFrom stats runif
#'@export
#'
#'
generator <- function(start = 0, dlength = 100, tot.spread = 100, presig = 0, postsig = 0,
  plength = 0, parts = c(15, 25, 50, 75, 85), sprd = c(50, 25, 100, 25, 50)) {
  # generate any pattern

  # check errors
  inputchecks(list(start, dlength, tot.spread, presig, postsig, plength, parts,
    sprd), "generator")
  if (parts[1] != 0 && sprd[1] != 0) {
    parts <- c(0, parts, 100)
    sprd <- c(0, sprd, 0)
  }

  plength <- length(parts) - 2


  sectgen <- function(sectlen, init, ref, spread, acc = 1e-05) {
    sector <- vector(length = sectlen)
    # print(ref) print(init)

    expmin <- ref * (1 - acc)
    expmax <- ref * (1 + acc)
    # print(expmin)
    repeat {
      cur <- init
      for (j in 1:sectlen) {
        sector[j] <- cur
        # going down
        if (ref < init)
          cur <- runif(1, sector[j] - spread, sector[j])
        # going up
        if (ref > init)
          cur <- runif(1, sector[j], spread + sector[j])
      }
      if (sector[sectlen] > expmin) {
        if (sector[sectlen] < expmax)
          break
      }
    }


    return(sector)
  }


  start.const <- start
  neg <- start - tot.spread
  negative <- FALSE
  if (neg <= 0) {
    start <- start - neg + 10
    negative <- TRUE
  }
  start.const <- start

  # make data
  output <- vector(length = dlength)

  partitions <- as.integer(round(parts/100 * dlength))
  pre_spreads <- sprd/100  ##same
  for (i in 1:(plength + 1)) {
    reference <- start.const + round(tot.spread * pre_spreads[i + 1])

    curspread <- 2 * tot.spread * abs(pre_spreads[i + 1] - pre_spreads[i])/(partitions[i +
      1] - partitions[i])
    # print(curspread)
    output[(partitions[i] + 1):partitions[i + 1]] <- sectgen((partitions[i +
      1] - partitions[i]), start, reference, curspread)
    start <- output[(partitions[i + 1] - 1)]

  }
  if (negative == TRUE)
    output <- output + neg - 10
  if (presig != 0) {
    pre <- vector(length = presig)
    pre <- rep(output[1], presig)
    output <- c(pre, output)
  }
  if (postsig != 0) {
    post <- vector(length = postsig)
    post <- rep(output[length(output)], postsig)
    output <- c(output, post)
  }
  return(output)
}





#'
#'Add noise to a time series
#'
#'This function lets you add artificial noise to time series, normally to patterns generated by \link{generator}.
#'Use different types and strengths of noise to test smoothers.
#'
#'For an overview of the package capabilities, click here \link{rpatrec}
#'
#'@param input Time series to which noise will be added
#'@param type String. Defines what type of noise to be added. Acceptable values are:\itemize{
#'    \item{\code{white} - white noise with variance \code{final_level}}
#'    \item{\code{red} - red noise with variance \code{final_level} (use with caution)}
#'}
#'@param final_level Number or \code{var}.
#'    A number sets the standard deviation to a constant value at each point.
#'    \code{var} sets the standard deviation to increase proportional to the (absolute value of the) signal at peaks.
#'
#'
#'@return Time series with added noise.
#'
#'@examples
#'\dontrun{
#'#Generate a HS patterns
#'a <- generator()
#'#now add white noise with a standdard deviation of 10
#'b <- noise(a,'white',10)
#'plot(b)
#'}
#'
#'@export
#'@importFrom stats rnorm
#'

noise <- function(input, type, final_level) {

  inputchecks(list(input, type, final_level), "noise")

  if (type == "var") {
    # set scale
    up <- max(abs(input))
    output <- vector(length = length(input))
    # create noise
    for (i in 1:length(input)) {
      output[i] <- input[i] + rnorm(1, 0, (abs(input[i])/up * final_level))
    }
  }
  if (type == "white") {
    output <- input + rnorm(length(input), 0, final_level)
  }
  if (type == "red") {
    noise <- cumsum(rnorm(length(input), 0, final_level))
    output <- input + noise
  }

  return(output)
}