test-Ops.R
In xts: eXtensible Time Series

all.modes <- c("double", "integer", "logical", "character")
ops.math <- c("+", "-", "*", "/", "^", "%%", "%/%")
ops.relation <- c(">", ">=", "==", "!=", "<=", "<")
ops.logic <- c("&", "|", ops.relation)
all.ops <- c(ops.math, ops.logic)

ops_numeric_tester <-
function(e1, e2, mode, op)
{
  storage.mode(e1) <- mode
  storage.mode(e2) <- mode
  eval(call(op, e1, e2))
}

make_msg <- function(info, op, type)
{
  sprintf("%s op: %s, type: %s", info, op, type)
}

### {{{ 2-column objects
info_msg <- "test.ops_xts2d_matrix2d_dimnames"
X1 <- .xts(cbind(1:3, 4:6), 1:3, dimnames = list(NULL, c("x", "y")))
M1 <- as.matrix(X1) * 5
M2 <- M1
colnames(M2) <- rev(colnames(M2))
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments should only change column names
    e <- ops_numeric_tester(M2, X1, m, o)
    E <- X1
    colnames(E) <- colnames(M2)
    E[] <- ops_numeric_tester(M2, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts2d_matrix2d_only_colnames"
X1 <- .xts(cbind(1:3, 4:6), 1:3, dimnames = list(NULL, c("x", "y")))
M1 <- coredata(X1) * 5
M2 <- M1
colnames(M2) <- rev(colnames(M2))
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments should only change column names
    e <- ops_numeric_tester(M2, X1, m, o)
    E <- X1
    colnames(E) <- colnames(M2)
    E[] <- ops_numeric_tester(M2, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts2d_matrix2d_only_rownames"

X1 <- .xts(cbind(1:3, 4:6), 1:3)
M1 <- coredata(X1) * 5
rownames(M1) <- format(.POSIXct(1:3))
M2 <- M1
colnames(M2) <- rev(colnames(M2))

for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments should only change column names
    e <- ops_numeric_tester(M2, X1, m, o)
    E <- X1
    colnames(E) <- colnames(M2)
    E[] <- ops_numeric_tester(M2, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts2d_matrix2d_no_dimnames"
X1 <- .xts(cbind(1:3, 1:3), 1:3)
M1 <- coredata(X1) * 5
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(M1, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(M1, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}
### }}} 2-column objects

### {{{ 1-column objects
info_msg <- "test.ops_xts1d_matrix1d_dimnames"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
M1 <- as.matrix(X1) * 5
M2 <- M1
colnames(M2) <- "y"
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments should only change column names
    e <- ops_numeric_tester(M2, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(M2, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    colnames(E) <- "y"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts1d_matrix1d_only_colnames"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
M1 <- coredata(X1) * 5
M2 <- M1
colnames(M2) <- "y"
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments should only change column names
    e <- ops_numeric_tester(M2, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(M2, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    colnames(E) <- "y"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts1d_matrix1d_only_rownames"
X1 <- .xts(1:3, 1:3)
M1 <- coredata(X1) * 5
rownames(M1) <- format(.POSIXct(1:3))
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(M1, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(M1, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts1d_matrix1d_no_dimnames"
X1 <- .xts(1:3, 1:3)
M1 <- coredata(X1) * 5
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(M1, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(M1, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts1d_xts1d"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next
    e <- ops_numeric_tester(X1, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(X1), coredata(X1), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts1d_xts1d_different_index"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
X2 <- .xts(2:4, 2:4, dimnames = list(NULL, "y"))
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, X2, m, o)
    E <- X1[2:3,]
    E[] <- ops_numeric_tester(coredata(E), coredata(X2[1:2,]), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments should only change column names
    e <- ops_numeric_tester(X2, X1, m, o)
    E <- X2[1:2,]
    E[] <- ops_numeric_tester(coredata(X1[2:3,]), coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}
### }}} 1-column objects

### {{{ xts with dim, vector
info_msg <- "test.ops_xts2d_vector_no_names"
X1 <- .xts(cbind(1:3, 4:6), 1:3, dimnames = list(NULL, c("x", "y")))
V1 <- as.vector(coredata(X1[,1L])) * 5
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, V1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), V1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(V1, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(V1, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts2d_vector_names"
X1 <- .xts(cbind(1:3, 4:6), 1:3, dimnames = list(NULL, c("x", "y")))
V1 <- setNames(as.vector(X1[,1L]), index(X1)) * 5
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, V1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), V1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(V1, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(V1, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts1d_vector_no_names"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
V1 <- as.vector(coredata(X1[,1L])) * 5
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, V1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), V1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(V1, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(V1, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts1d_vector_names"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
V1 <- setNames(as.vector(X1[,1L]), index(X1)) * 5
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(X1, V1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(E), V1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(V1, X1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(V1, coredata(E), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}
### }}} xts with dim, vector

### {{{ xts no dims, matrix/vector
info_msg <- "test.ops_xts_no_dim_matrix1d"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
Xv <- drop(X1)
M1 <- coredata(X1) * 5
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(Xv, M1, m, o)
    E <- X1
    E[] <- ops_numeric_tester(coredata(Xv), M1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(M1, Xv, m, o)
    E <- X1
    E[] <- ops_numeric_tester(M1, coredata(Xv), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts_no_dim_matrix2d"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
Xv <- drop(X1)
X2 <- merge(x = Xv * 2, y = Xv * 5)
M2 <- coredata(X2)
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(Xv, M2, m, o)
    E <- X2
    E[] <- ops_numeric_tester(coredata(Xv), M2, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    # results no identical because attributes change order
    expect_equal(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(M2, Xv, m, o)
    E <- X2
    E[] <- ops_numeric_tester(M2, coredata(Xv), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    # results no identical because attributes change order
    expect_equal(e, E, info = make_msg(info_msg, o, m))
  }
}

info_msg <- "test.ops_xts_no_dim_vector"
X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x"))
Xv <- drop(X1)
V1 <- 4:6
for (o in all.ops) {
  for (m in all.modes) {
    if ("character" == m && !(o %in% ops.relation))
      next

    e <- ops_numeric_tester(Xv, V1, m, o)
    E <- Xv
    E[] <- ops_numeric_tester(coredata(Xv), V1, m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))

    # order of arguments shouldn't matter
    e <- ops_numeric_tester(V1, Xv, m, o)
    E <- Xv
    E[] <- ops_numeric_tester(V1, coredata(Xv), m, o)
    if (o %in% ops.logic) storage.mode(E) <- "logical"
    expect_identical(e, E, info = make_msg(info_msg, o, m))
  }
}
### }}} xts vector, matrix/vector

### These tests check that the time class of a time series on which
### a relational operator is applied is not changed.
ts1 <- xts(17, order.by = as.Date('2020-01-29'))

info_msg <- "test.get_tclass_ts1"
expect_identical(tclass(ts1), c("Date"), info = info_msg)

info_msg <- "test.tclass_after_rel_op"
expect_identical(tclass(ts1 < 0), c("Date"), info = paste(info_msg, "| <"))
expect_identical(tclass(ts1 > 0), c("Date"), info = paste(info_msg, "| >"))
expect_identical(tclass(ts1 <= 0), c("Date"), info = paste(info_msg, "| <="))
expect_identical(tclass(ts1 >= 0), c("Date"), info = paste(info_msg, "| >="))
expect_identical(tclass(ts1 == 0), c("Date"), info = paste(info_msg, "| =="))
expect_identical(tclass(ts1 != 0), c("Date"), info = paste(info_msg, "| !="))

tstz <- "Atlantic/Reykjavik"
ts2 <- xts(17, order.by = as.POSIXct("2020-01-29", tz = tstz))

info_msg <- "test.get_tclass_POSIXct_ts2"
expect_true("POSIXct" %in% tclass(ts2), info = info_msg)

info_msg <- "test.tclass_POSIXct_after_rel_op"
expect_true("POSIXct" %in% tclass(ts2 <  0), info = paste(info_msg, "| <"))
expect_true("POSIXct" %in% tclass(ts2 >  0), info = paste(info_msg, "| >"))
expect_true("POSIXct" %in% tclass(ts2 <= 0), info = paste(info_msg, "| <="))
expect_true("POSIXct" %in% tclass(ts2 >= 0), info = paste(info_msg, "| >="))
expect_true("POSIXct" %in% tclass(ts2 == 0), info = paste(info_msg, "| =="))
expect_true("POSIXct" %in% tclass(ts2 != 0), info = paste(info_msg, "| !="))

info_msg <- "test.get_tzone_ts2"
expect_identical(tzone(ts2), tstz, info = info_msg)

info_msg <- "test.tzone_after_rel_op"
expect_identical(tzone(ts2 <  0), tstz, info = paste(info_msg, "| <"))
expect_identical(tzone(ts2 >  0), tstz, info = paste(info_msg, "| >"))
expect_identical(tzone(ts2 <= 0), tstz, info = paste(info_msg, "| <="))
expect_identical(tzone(ts2 >= 0), tstz, info = paste(info_msg, "| >="))
expect_identical(tzone(ts2 == 0), tstz, info = paste(info_msg, "| =="))
expect_identical(tzone(ts2 != 0), tstz, info = paste(info_msg, "| !="))

### Ops.xts() doesn't change column names
x <- .xts(1:3, 1:3, dimnames = list(NULL, c("-1")))
z <- as.zoo(x)
expect_equal(names(x + x[-1,]), names(z + z[-1,]),
            "Ops.xts() doesn't change column names when merge() is called")
expect_equal(names(x + x), names(z + z),
            "Ops.xts() doesn't change column names when indexes are equal")

### Ops.xts returns derived class
st <- Sys.time()
x1 <- xts(1, st)
x2 <- xts(2, st)
x3 <- xts(3, st)  # regular xts object
# derived class objects
klass <- c("foo", "xts", "zoo")
class(x1) <- klass
class(x2) <- klass
expect_identical(klass, class(x1 + x2), "Ops.xts('foo', 'foo') returns derived class")
expect_identical(klass, class(x2 + x1), "Ops.xts('foo', 'foo') returns derived class")
expect_identical(klass, class(x1 + x3), "Ops.xts('foo', 'xts') returns derived class")
expect_identical(class(x3), class(x3 + x1), "Ops.xts('xts', 'foo') returns xts class")

info_msg <- "test.Ops.xts_unary"
xpos <- xts(1, .Date(1))
xneg <- xts(-1, .Date(1))
lt <- xts(TRUE, .Date(1))
lf <- xts(FALSE, .Date(1))
expect_identical(xpos, +xpos, info = paste(info_msg, "+ positive xts"))
expect_identical(xneg, +xneg, info = paste(info_msg, "+ negative xts"))
expect_identical(xneg, -xpos, info = paste(info_msg, "- positive xts"))
expect_identical(xpos, -xneg, info = paste(info_msg, "- negative xts"))

expect_identical(lf, !lt, info = paste(info_msg, "! TRUE"))
expect_identical(lt, !lf, info = paste(info_msg, "! FALSE"))