test_that matcher utilities

test_that_util.r

# Find expression that created a variable 
find_expr <- testthat:::find_expr


includes <- function(x, included) {
  if (length(included) > 0) {
    if (is.list(included)) {
      for (name in names(included)) {
        if (!all(x[[name]] == included[[name]])) {
          return(FALSE)
        }
      }
    } else {
      for (value in included) {
        if (!(value %in% x)) {
          return(FALSE)
        }
      }
    }
  }
  TRUE
}



is_proto <- function(name=NULL) {
  function(x) {
    expectation(
      is.proto(x) && (is.null(name) || (!is.null(name) && x$..Name == name)),
      ifelse(is.null(name), "is not a proto object",  paste('is not a proto object with name', name))
    )
  }
}

expect_proto <- function(object, expected=NULL, info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expect_that(object, is_proto(expected), info, label)
}


is_function <- function() {
  function(x) {
    expectation(
      is.function(x),
      "is not a function"
    )
  }
}

expect_function <- function(object, info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expect_that(object, is_function(), info, label)
}


is_null <- function() {
  function(x) {
    expectation(
      is.null(x),
      "is not NULL"
    )
  }
}

expect_null <- function(object, info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expect_that(object, is_null(), info, label)
}


has_length <- function(n) {
  function(x) {
    expectation(
      length(x) == n,
      paste('does not have length', n)
    )
  }
}

expect_length <- function(object, expected, info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expect_that(object, has_length(expected), info, label)
}


has_method <- function(name) {
  name <- as.character(name)
  function(x) {
    expectation(
      has_method_impl(x, name),
      paste('does not have method', name)
    )
  }
}

has_method_impl <- function(x, name) UseMethod("has_method_impl")

has_method_impl.default <- function(x, name) {
  is.function(x[[name]])
}

has_method_impl.proto <- function(x, name) {
  stopifnot(is.proto(x))
  # @todo not all functions are methods
  name %in% all.proto.functions(x)
}

expect_method <- function(object, expected, info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expect_that(object, has_method(expected), info, label)
}


has_interface <- function(...) {
  methods <- as.character(c(...))
  function(x) {
    passed <- TRUE
    for (name in methods) {
      if (!has_method_impl(x, name)) {
        passed <- FALSE
        break
      }
    }
    expectation(passed, paste('does not have method', name))
  }
}

expect_interface <- function(object, ..., info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expected <- list(...)
  expect_that(object, has_interface(expected), info, label)
}


includes_matcher <- function(expected) {
  function(x) {
    expectation(
      includes(x, expected),
      paste('does not include', as.character(expected))
    )
  }
}


expect_includes <- function(object, expected, info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expect_that(object, includes_matcher(expected), info, label)
}


is_list <- function(expected = NULL) {
  function(x) {
    expectation(
      is.list(x) && (is.null(expected) || (!is.null(expected) && includes(x, expected))),
      paste('is not a list that includes', as.character(expected))
    )
  }
}


expect_list <- function(object, expected=NULL, info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expect_that(object, is_list(expected), info, label)
}


is_mongo_doc <- function(id = NULL) {
  function(x) {
    expectation(
      is.list(x) && length(x) > 0 && 
      !is.null(x[['_id']]) && class(x[['_id']]) == 'mongo.oid' &&
      (is.null(id) || (!is.null(id) && as.character(x[['_id']]) == as.character(id))),
      ifelse(is.null(id), "is not a Mongo document",  paste('is not a Mongo document with _id', id))
    )
  }
}

expect_mongo_doc <- function(object, id=NULL, info = NULL, label = NULL) {
  if (is.null(label)) {
    label <- find_expr("object")
  }
  expect_that(object, is_mongo_doc(id), info, label)
}