tests/testthat/test-segmentPattern.R

# rm(list = ls())

# library(adept)
# library(testthat)

context("Testing segmentPattern function.")

######################
######################
######################
###   Examples 1   ###
######################
######################
######################

test_that("Example 1(a): no noise in signal, all pattern occurences of the same
          length (vector length: 101)", {

  ## Generate signal and template
  x0 <- cos(seq(0, 2 * pi * 10, length.out = 1001))
  x  <- x0
  template <- x0[1:101]

  pattern.dur.seq <- c(90, 100, 110)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor")

  res <- sort(out$tau_i)
  res.exp <- c(1, 101, 201, 302, 401, 501, 601, 701, 801, 901)
  # expect_equal(res, res.exp)
  ## @MK May 11, 2019: account for micro differences in similarity matrix
  ## computation osx/win which may yield up to 1 index difference in stride location
  ## estimation
  expect_true(max(abs(res - res.exp)) <= 1)


  res <- sort(out$T_i)
  res.exp <- c(100, 100, 100, 100, 100, 100, 100, 100, 100, 100)
  # expect_equal(res, res.exp)
  ## @MK May 11, 2019: account for micro differences in similarity matrix
  ## computation osx/win which may yield up to 1 index difference in stride location
  ## estimation
  expect_true(max(abs(res - res.exp)) <= 1)

})



test_that("Example 1(b): no noise in signal, all pattern occurences of the same length
          (vector length: 101), include in grid of considered pattern durations the
          true value 101", {

  ## Generate signal and template
  x0 <- cos(seq(0, 2 * pi * 10, length.out = 1001))
  x  <- x0
  template <- x0[1:101]

  pattern.dur.seq <- c(90, 100, 101, 102, 110)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor")

  res <- sort(out$tau_i)
  res.exp <- c(1, 101, 201, 301, 401, 501, 601, 701, 801, 901)
  expect_equal(res, res.exp)

  res <- sort(out$T_i)
  res.exp <- c(101, 101, 101, 101, 101, 101, 101, 101, 101, 101)
  expect_equal(res, res.exp)

  res <- sort(out$sim_i)
  res.exp <- c(0.999999999999999, 0.999999999999999, 1, 1, 1, 1, 1, 1, 1,
               1)
  expect_equal(res, res.exp)
})



test_that("Example 1(c): no noise in signal, all pattern occurences of the same length
          (vector length: 101), include in grid of considered pattern durations the
          true value 101,
          modify assumed signal frequency and scale of grid of pattern durations", {

  ## Generate signal and template
  x0 <- cos(seq(0, 2 * pi * 10, length.out = 1001))
  x  <- x0
  template <- x0[1:101]

  pattern.dur.seq <- c(90, 100, 101, 102, 110) * 0.01
  out <- segmentPattern(x = x,
                        x.fs = 100,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor")

  res <- sort(out$tau_i)
  res.exp <- c(1, 101, 201, 301, 401, 501, 601, 701, 801, 901)
  expect_equal(res, res.exp)

  res <- sort(out$T_i)
  res.exp <- c(101, 101, 101, 101, 101, 101, 101, 101, 101, 101)
  expect_equal(res, res.exp)

  res <- sort(out$sim_i)
  res.exp <- c(0.999999999999999, 0.999999999999999, 1, 1, 1, 1, 1, 1, 1,
               1)
  expect_equal(res, res.exp)
})



######################
######################
######################
###   Examples 2   ###
######################
######################
######################

# set.seed(1)
# s.grid <- sample(60:120, size = 10)
## changed to correct for sample function bias in new release of R
s.grid <- c(76L, 82L, 93L, 112L, 71L, 110L, 111L, 95L, 118L, 63L)

if (exists("template")) rm(template)

test_that("Example 2(a): no noise in signal (no peak fine-tuning employed),
          pattern occurences of different length", {

  ## Grid of different true pattern occurence durations
  template <- cos(seq(0, 2 * pi, length.out = 200))

  ## Generate signal x that consists of "glued" pattern occurrences of different length
  x <- numeric()
  for (ss in s.grid){
    templ0 <- approx(seq(0, 1, length.out = 200), template, xout = seq(0, 1, length.out = ss))$y
    if (length(x)>0){
      x <- x[-length(x)]
    }
    x <- c(x, templ0)
  }

  ## Assume grid of assumed duration of pattern occurrences
  pattern.dur.seq <- 60:120
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor")

  res <- out$tau_i
  res.exp <- c(1, 76, 157, 249, 360, 430, 539, 649, 743, 860)
  expect_equal(res, res.exp)

  res <- out$T_i
  res.exp <- c(76, 82, 93, 112, 71, 110, 111, 95, 118, 63)
  expect_equal(res, res.exp)

  res <- out$sim_i
  res.exp <- c(0.999999999999989, 0.999999999999991, 0.99999999999999, 0.99999999999999,
               0.999999999999991, 0.999999999999988, 0.999999999999991, 0.999999999999991,
               0.999999999999989, 0.999999999999992)
  expect_equal(res, res.exp)
})




test_that("Example 2(b): no noise in signal (no peak fine-tuning employed),
          pattern occurences of different length; What happens if we define very
          'poor' grid of assumed duration of pattern occurrences?", {

  ## Grid of different true pattern occurence durations
  template <- cos(seq(0, 2 * pi, length.out = 200))

  ## Generate signal x that consists of "glued" pattern occurrences of different length
  x <- numeric()
  for (ss in s.grid){
    templ0 <- approx(seq(0, 1, length.out = 200), template, xout = seq(0, 1, length.out = ss))$y
    if (length(x)>0){
      x <- x[-length(x)]
    }
    x <- c(x, templ0)
  }

  ## Assume grid of assumed duration of pattern occurrences
  pattern.dur.seq <- c(60, 80, 100, 120)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor")

  res <- out$tau_i
  res.exp <- c(9, 77, 163, 245, 366, 435, 534, 656, 742, 861)
  # expect_equal(res, res.exp)
  ## @MK May 11, 2019: account for micro differences in similarity matrix
  ## computation osx/win which may yield up to 1 index difference in stride location
  ## estimation
  expect_true(max(abs(res - res.exp)) <= 1)

  res <- out$T_i
  res.exp <- c(60, 80, 80, 120, 60, 100, 120, 80, 120, 60)
  # expect_equal(res, res.exp)
  ## @MK May 11, 2019: account for micro differences in similarity matrix
  ## computation osx/win which may yield up to 1 index difference in stride location
  ## estimation
  expect_true(max(abs(res - res.exp)) <= 1)

})




test_that("Example 2(c): no noise in signal (no peak fine-tuning employed),
          pattern occurences of different length; Use covariance", {

  ## Grid of different true pattern occurence durations
  template <- cos(seq(0, 2 * pi, length.out = 200))

  ## Generate signal x that consists of "glued" pattern occurrences of different length
  x <- numeric()
  for (ss in s.grid){
    templ0 <- approx(seq(0, 1, length.out = 200), template, xout = seq(0, 1, length.out = ss))$y
    if (length(x)>0){
      x <- x[-length(x)]
    }
    x <- c(x, templ0)
  }

  ## Assume grid of assumed duration of pattern occurrences
  pattern.dur.seq <- c(60, 80, 100, 120)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cov")

  res <- out$tau_i
  res.exp <- c(1, 87, 154, 255, 355, 435, 534, 657, 742, 861)
  ## @MK Jun 15, 2019: account for micro differences in similarity matrix
  ## computation osx/win which may yield up to 1 index difference in stride location
  ## estimation
  expect_true(max(abs(res - res.exp)) <= 1)
  # expect_equal(res, res.exp)

  res <- out$T_i
  res.exp <- c(80, 60, 100, 100, 80, 100, 120, 80, 120, 60)
  # expect_equal(res, res.exp)
  ## @MK Jun 15, 2019: account for micro differences in similarity matrix
  ## computation osx/win which may yield up to 1 index difference in stride location
  ## estimation
  expect_true(max(abs(res - res.exp)) <= 1)
  # expect_equal(res, res.exp)
})




######################
######################
######################
###   Examples 3   ###
######################
######################
######################



test_that("Example 3(a): add noise in signal generation,
          pattern occurences of different length in singal generation", {

  template <- cos(seq(0, 2 * pi, length.out = 200))

  x <- numeric()
  for (ss in s.grid){
    templ0 <- approx(seq(0, 1, length.out = 200), template, xout = seq(0, 1, length.out = ss))$y
    if (length(x)>0){
      x <- x[-length(x)]
    }
    x <- c(x, templ0)
  }

  set.seed(1)
  x <- x + rnorm(length(x), sd = 0.3)

  pattern.dur.seq <- seq(60, 100, by = 5)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor")

  res <- out$tau_i
  res.exp <- c(4, 73, 162, 255, 362, 435, 545, 645, 752, 862)
  expect_equal(res, res.exp)

  res <- out$T_i
  res.exp <- c(70, 90, 85, 100, 65, 100, 100, 100, 100, 60)
  expect_equal(res, res.exp)

  res <- out$sim_i
  res.exp <- c(0.932841298514519, 0.937485762099541, 0.903795488242938, 0.902713349912544,
               0.915232790752724, 0.87794212230542, 0.894118326687643, 0.907734430293421,
               0.893770550717209, 0.93223222750356)
  expect_equal(res, res.exp)
})




test_that("Example 3(b): add noise in signal generation,
          pattern occurences of different length in singal generation", {

  ## Generate signal and template
  template <- cos(seq(0, 2 * pi, length.out = 200))

  x <- numeric()
  for (ss in s.grid){
    templ0 <- approx(seq(0, 1, length.out = 200), template, xout = seq(0, 1, length.out = ss))$y
    if (length(x)>0){
      x <- x[-length(x)]
    }
    x <- c(x, templ0)
  }

  set.seed(1)
  x <- x + rnorm(length(x), sd = 0.3)

  ## Without maxima detection
  pattern.dur.seq <- seq(60, 100, by = 5)


  # similarity.measure.thresh = 0.0
  # x.adept.ma.W = NULL
  # finetune = NULL
  # finetune.maxima.ma.W = NULL
  # finetune.maxima.nbh.W = NULL
  # run.parallel = FALSE
  # run.parallel.cores = NULL
  # x.cut = TRUE
  # x.cut.vl = 6000
  # compute.template.idx = FALSE

  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor")

  res <- out$tau_i
  res.exp <- c(4, 73, 162, 255, 362, 435, 545, 645, 752, 862)
  expect_equal(res, res.exp)

  res <- out$T_i
  res.exp <- c(70, 90, 85, 100, 65, 100, 100, 100, 100, 60)
  expect_equal(res, res.exp)

  res <- out$sim_i
  res.exp <- c(0.932841298514519, 0.937485762099541, 0.903795488242938, 0.902713349912544,
               0.915232790752724, 0.87794212230542, 0.894118326687643, 0.907734430293421,
               0.893770550717209, 0.93223222750356)
  expect_equal(res, res.exp)


  # similarity.measure = "cor"
  # finetune = "maxima"
  # finetune.maxima.ma.W = 30
  # finetune.maxima.nbh.W = 120

  ## Use maxima detection (for comparison)
  pattern.dur.seq <- seq(60, 100, by = 5)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor",
                        finetune = "maxima",
                        finetune.maxima.ma.W = 30,
                        finetune.maxima.nbh.W = 120)

  res <- out$tau_i
  res.exp <- c(15, 75, 160, 253, 355, 435, 542, 648, 750, 849)
  expect_equal(res, res.exp)

  res <- out$T_i
  res.exp <- c(61, 86, 92, 100, 77, 100, 100, 98, 100, 60)
  expect_equal(res, res.exp)

  res <- out$sim_i
  res.exp <- c(0.934034172881348, 0.937485762099541, 0.914074642973907, 0.902713349912544,
               0.915232790752724, 0.87794212230542, 0.894118326687643, 0.907734430293421,
               0.888048574952028, 0.93223222750356)
  expect_equal(res, res.exp)



  ## Use maxima detection, use thresholding on covariance
  pattern.dur.seq <- seq(60, 100, by = 5)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure.thresh = 0.7,
                        similarity.measure = "cov",
                        finetune = "maxima",
                        finetune.maxima.ma.W = 30,
                        finetune.maxima.nbh.W = 120)

  res <- out$tau_i
  res.exp <- c(15, 160, 648, 849)
  expect_equal(res, res.exp)

  res <- out$T_i
  res.exp <- c(61, 92, 98, 60)
  expect_equal(res, res.exp)

  res <- out$sim_i
  res.exp <- c(0.724850738169134, 0.736528364289848, 0.717833003791632, 0.743334116677552)
  expect_equal(res, res.exp)



  ## Use maxima detection, use thresholding on covariance,
  ## and add smoothing
  pattern.dur.seq <- seq(60, 100, by = 5)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure.thresh = -1,
                        x.adept.ma.W = 30,
                        similarity.measure = "cov",
                        finetune = "maxima",
                        finetune.maxima.ma.W = 30,
                        finetune.maxima.nbh.W = 120)

  res <- out$tau_i
  res.exp <- c(15, 75, 160, 253, 355, 435, 542, 648, 751, 857)
  expect_equal(res, res.exp)

  res <- out$T_i
  res.exp <- c(61, 86, 92, 100, 77, 100, 100, 98, 100, 60)
  expect_equal(res, res.exp)

  res <- out$sim_i
  res.exp <- c(0.398855621994664, 0.574913156763604, 0.613893094434027, 0.562563743167577,
               0.544951870561808, 0.562680022332807, 0.563855908578859, 0.614970735584006,
               0.593536450844769, 0.320552985778579)
  expect_equal(res, res.exp)


  ## increase range of allowed pattern duration (pattern.dur.seq)
  pattern.dur.seq <- seq(50, 150, by = 5)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor",
                        finetune = "maxima",
                        finetune.maxima.ma.W = 30,
                        finetune.maxima.nbh.W = 120)

  res <- out$tau_i
  res.exp <- c(15, 75, 160, 251, 355, 431, 541, 648, 745, 857)
  expect_equal(res, res.exp)

  res <- out$T_i
  res.exp <- c(61, 86, 92, 105, 77, 111, 108, 98, 113, 52)
  expect_equal(res, res.exp)

  res <- out$sim_i
  res.exp <- c(0.934034172881348, 0.937485762099541, 0.914074642973907, 0.920834847349191,
               0.915232790752724, 0.896116452119818, 0.91682323488697, 0.9072682178912,
               0.898872120860981, 0.93223222750356)
  expect_equal(res, res.exp)

})






######################
######################
######################
###   Examples 4   ###
######################
######################
######################

## CHECKING FOR x.cut = TRUE correctness


test_that("Example 4(a): no noise in signal, all pattern occurences of the same
          length, long signal. We check for same behaviour with and without x.cut = TRUE", {

  ## Generate signal and template
  ## approx 30 min for data collected at freq
  x0 <- cos(seq(0, 2 * pi * 10 * 20, length.out = 1000 * 20 + 1))
  x  <- x0
  template <- x0[1:101]

  pattern.dur.seq <- c(90, 100, 101)
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor",
                        x.cut = TRUE,
                        x.cut.vl = 6000)

  res <- as.vector(summary(out$tau_i))
  res.exp <- c(1, 4976, 9951, 9951, 14926, 19901)
  expect_equal(res, res.exp)

  res <- as.vector(summary(out$T_i))
  res.exp <- c(101, 101, 101, 101, 101, 101)
  expect_equal(res, res.exp)

  res <- as.vector(summary(out$sim_i))
  res.exp <- c(0.999999999999998, 1, 1, 1, 1, 1)
  expect_equal(res, res.exp)

  ## compare with no cut
  out2 <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor",
                        x.cut = FALSE)

  expect_equal(out$tau_i, out2$tau_i)
  expect_equal(out$T_i,   out2$T_i)
  expect_equal(out$sim_i, out2$sim_i)
})


######################
######################
######################
###   Examples 5   ###
######################
######################
######################

## PARALLEL COMPUTATION CHECKING


test_that("Example 5(a). Setting: no noise in signal, all pattern occurences of the same
          length, long signal. We check for the same behaviour with and without parallel
          computation with fixed number of 2 cores.", {

  skip_on_os("windows")

  # Generate signal and template
  # approx 30 min for data collected at freq
  x0 <- cos(seq(0, 2 * pi * 10 * 20, length.out = 1000 * 20 + 1))
  x  <- x0
  template <- x0[1:101]

  pattern.dur.seq <- c(90, 100, 101)

  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = template,
                        pattern.dur.seq = pattern.dur.seq,
                        similarity.measure = "cor",
                        x.cut = TRUE,
                        x.cut.vl = 6000,
                        compute.template.idx = TRUE)

  out2 <- segmentPattern(x = x,
                         x.fs = 1,
                         template = template,
                         pattern.dur.seq = pattern.dur.seq,
                         similarity.measure = "cor",
                         x.cut = TRUE,
                         x.cut.vl = 6000,
                         run.parallel = TRUE,
                         run.parallel.cores = 2,
                         compute.template.idx = TRUE)

  expect_equal(out$tau_i, out2$tau_i)
  expect_equal(out$T_i,   out2$T_i)
  expect_equal(out$sim_i, out2$sim_i)
  expect_equal(out$template_i, out2$template_i)
})



######################
######################
######################
###   Examples 6   ###
######################
######################
######################

## CHECKING FOR TEMPLATE INDEX

# set.seed(1)
# s.grid2 <- sample(60:120, size = 50)
s.grid2 <- c(76L, 82L, 93L, 112L, 71L, 110L, 111L, 95L, 118L, 63L, 70L,
            68L, 117L, 78L, 96L, 119L, 92L, 103L, 120L, 104L, 98L, 109L,
            85L, 64L, 69L, 73L, 60L, 113L, 88L, 115L, 74L, 77L, 90L, 65L,
            105L, 89L, 79L, 62L, 102L, 106L, 100L, 72L, 101L, 81L, 80L, 84L,
            94L, 66L, 86L, 99L)

test_that("Example 6(a): test returning template index matrix", {


  ## Grid of different true pattern occurence durations
  template1 <- cos(seq(0, 2 * pi, length.out = 200))
  template2 <- c(rev(seq(-1, 1, length.out = 100)), seq(-1, 1, length.out = 100))

  ## Generate signal x that consists of "glued" pattern occurrences of different length
  x <- numeric()
  for (ss in s.grid2){
    ## Add piece from template1
    templ0 <- approx(seq(0, 1, length.out = 200), template1, xout = seq(0, 1, length.out = ss))$y
    if (length(x)>0) x <- x[-length(x)]
    x <- c(x, templ0)
    ## Add piece from template2
    templ0 <- approx(seq(0, 1, length.out = 200), template2, xout = seq(0, 1, length.out = ss))$y
    if (length(x)>0) x <- x[-length(x)]
    x <- c(x, templ0)

  }

  ## Run ADEPT
  out <- segmentPattern(x = x,
                        x.fs = 1,
                        template = list(template1, template2),
                        pattern.dur.seq = sort(s.grid2),
                        similarity.measure = "cor",
                        compute.template.idx = TRUE)

  expect_true(all(out$template_i == rep(c(1,2), 50)))
})



############################################
############################################
############################################
###   Technical checking A   ###############
############################################
############################################
############################################




test_that("Testing that errors are thrown if invalid objects are passed to the function", {

  ## Generate signal and template
  x0 <- cos(seq(0, 2 * pi * 10, length.out = 1001))
  x  <- x0
  template <- x0[1:101]
  pattern.dur.seq <- c(90, 100, 110)

  # suppressWarnings({
    expect_error(segmentPattern(c(x, "a"), 1, template, pattern.dur.seq))
    expect_error(segmentPattern(x, "a", template, pattern.dur.seq))
    expect_error(segmentPattern(x, 1, list(template, list("a")), pattern.dur.seq))
    expect_error(segmentPattern(x, 1, rep("A", 10), pattern.dur.seq))
    expect_error(segmentPattern(x, 1, template, c(1, "a")))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, "corr"))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, x.adept.ma.W = "a"))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, finetune = "maxima2"))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, finetune.maxima.ma.W = -1))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, finetune.maxima.nbh.W = -1))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, run.parallel = 3))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, run.parallel.cores = 0))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, x.cut = NA))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, x.cut.vl = -1))
    expect_error(segmentPattern(x, 1, template, pattern.dur.seq, compute.template.idx = 3))
  # })
})

Try the adept package in your browser

Any scripts or data that you put into this service are public.

adept documentation built on Feb. 1, 2021, 5:06 p.m.