R/assertions.R

Defines functions is_zeligei is_timeseries is_varying is_length_not_1 is_simsrange1 is_simsrange is_simsx1 is_simsx is_sims_present is_uninitializedField is_zelig

Documented in is_length_not_1 is_sims_present is_simsrange is_simsrange1 is_simsx is_simsx1 is_timeseries is_uninitializedField is_varying is_zelig is_zeligei

#' Check if is a zelig object
#' @param x an object
#' @param fail logical whether to return an error if x is not a Zelig object.

is_zelig <- function(x, fail = TRUE) {
    is_it <- inherits(x, "Zelig")
    if (isTRUE(fail)) {
        if(!isTRUE(is_it)) stop('Not a Zelig object.', call. = FALSE)
    } else return(is_it)
}

#' Check if uninitializedField
#' @param x a zelig.out method
#' @param msg character string with the error message to return if
#'   \code{fail = TRUE}.
#' @param fail logical whether to return an error if x uninitialzed.

is_uninitializedField <- function(x,
                                  msg = 'Zelig model has not been estimated.',
                                  fail = TRUE) {
    passes <- FALSE
    if (length(x) == 1) passes <- inherits(x, "uninitializedField")

    if (isTRUE(fail)) {
        if (isTRUE(passes))
            stop(msg, call. = FALSE)
    } else return(passes)
}

#' Check if any simulations are present in sim.out
#' @param x a sim.out method
#' @param fail logical whether to return an error if no simulations are present.

is_sims_present <- function(x, fail = TRUE) {
    passes <- TRUE
    if (is.null(x$x) & is.null(x$range)) passes <- FALSE
    if (length(x) > 0) passes <- TRUE
    if (isTRUE(fail)) {
        if (!isTRUE(passes))
            stop('No simulated quantities of interest found.', call. = FALSE)
    } else return(passes)
}

#' Check if simulations for individual values are present in sim.out
#' @param x a sim.out method
#' @param fail logical whether to return an error if simulation range is not
#'   present.

is_simsx <- function(x, fail = TRUE) {
    passes <- TRUE
    if (is.null(x$x)) passes <- FALSE
    if (isTRUE(fail)) {
        if (!isTRUE(passes))
            stop('Simulations for individual fitted values are not present.',
                call. = FALSE)
    } else return(passes)
}

#' Check if simulations for individual values for x1 are present
#'   in sim.out
#' @param x a sim.out method
#' @param fail logical whether to return an error if simulation range is not
#'   present.

is_simsx1 <- function(x, fail = TRUE) {
    passes <- TRUE
    if (is.null(x$x1)) passes <- FALSE
    if (isTRUE(fail)) {
        if (!isTRUE(passes))
            stop('Simulations for individual fitted values are not present.',
                call. = FALSE)
    } else return(passes)
}

#' Check if simulations for a range of fitted values are present in sim.out
#' @param x a sim.out method
#' @param fail logical whether to return an error if simulation range is not
#'   present.

is_simsrange <- function(x, fail = TRUE) {
    passes <- TRUE
    if (is.null(x$range)) passes <- FALSE
    if (isTRUE(fail)) {
        if (!isTRUE(passes))
            stop('Simulations for a range of fitted values are not present.',
                call. = FALSE)
    } else return(passes)
}

#' Check if simulations for a range1 of fitted values are present in sim.out
#' @param x a sim.out method
#' @param fail logical whether to return an error if simulation range is not
#'   present.

is_simsrange1 <- function(x, fail = TRUE) {
    passes <- TRUE
    if (is.null(x$range1)) passes <- FALSE
    if (isTRUE(fail)) {
        if (!isTRUE(passes))
            stop('Simulations for a range of fitted values are not present.',
                call. = FALSE)
    } else return(passes)
}

#' Check if an object has a length greater than 1
#' @param x an object
#' @param msg character string with the error message to return if
#'   \code{fail = TRUE}.
#' @param fail logical whether to return an error if length is not greater than
#'   1.

is_length_not_1 <- function(x, msg = 'Length is 1.', fail = TRUE) {
    passes <- TRUE

    if (length(x) == 1) passes <- FALSE
    if (isTRUE(fail)) {
        if (!isTRUE(passes))
            stop(msg, call. = FALSE)
    } else return(passes)
}

#' Check if the values in a vector vary
#' @param x a vector
#' @param msg character string with the error message to return if
#'   \code{fail = TRUE}.
#' @param fail logical whether to return an error if \code{x} does not vary.

is_varying <- function(x, msg = 'Vector does not vary.', fail = TRUE) {
    if (!is.vector(x)) stop('x must be a vector.', call. = FALSE)
    passes <- TRUE

    if (length(unique(x)) == 1) passes <- FALSE
    if (isTRUE(fail)) {
        if (!isTRUE(passes))
            stop(msg, call. = FALSE)
    } else return(passes)
}

#' Check if a zelig object contains a time series model
#'
#' @param x a zelig object
#' @param msg character string with the error message to return if
#'   \code{fail = TRUE}.
#' @param fail logical whether to return an error if \code{x} is not a timeseries.

is_timeseries <- function(x, msg = 'Not a timeseries object.', fail = FALSE) {
    is_zelig(x)
    passes <- TRUE
    if (!"timeseries" %in% x$category) passes <- FALSE
    if (isTRUE(fail)) {
        if (!isTRUE(passes))
            stop(msg, call. = FALSE)
    } else return(passes)
}

#' Check if an object was created with ZeligEI
#'
#' @param x a zelig object
#' @param msg character string with the error message to return if
#'   \code{fail = TRUE}.
#' @param fail logical whether to return an error if \code{x} is not a timeseries.

is_zeligei <- function(x, msg = "Function is not relevant for ZeligEI objects.",
                       fail = TRUE) {
    is_zelig(x)
    passes <- FALSE

    pkgs <- attr(class(x), "package")
    if ("ZeligEI" %in% pkgs) passes <- TRUE
    if (isTRUE(fail)) {
        if (isTRUE(passes))
            stop(msg, call. = FALSE)
    } else return(passes)
}

Try the Zelig package in your browser

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

Zelig documentation built on Jan. 8, 2021, 2:26 a.m.