R/check_arguments.R

Defines functions check_H check_P1 check_a1 check_R check_T check_Z create_regression check_C check_D check_target check_prior check_u check_phi check_rho check_mu check_beta check_xreg check_sd check_distribution check_y

check_y <- function(x, multivariate = FALSE, distribution = "gaussian") {
  if (any(!is.na(x))) {
    if (multivariate) {
      if (!is.matrix(x)) {
        stop("Argument y must be a matrix or multivariate ts object.")
      }
      if (nrow(x) < 2) {
        stop("Number of rows in y, i.e. number of time points, must be > 1. ")
      }
    } else {
      if (!is.vector(x) || is.list(x)) {
        if (is.ts(x) || is.matrix(x)) {
          if (!is.null(dim(x)) && ncol(x) == 1 && length(dim(x)) < 3) {
            dim(x) <- NULL
          } else {
            if(!is.null(dim(x)) && ncol(x) > 1) {
              stop("Argument y must be a vector or univariate ts object.")
            }
          }
        } else {
          stop("Argument y must be a vector or univariate ts object.")
        }
      }
      if (length(x) < 2) {
        stop("Length of argument y, i.e. number of time points, must be > 1.")
      }
      if (distribution != "gaussian" && any(na.omit(x) < 0)) {
        stop(paste0("Negative values not allowed for ", distribution, 
          " distribution. "))
      } else {
        if (distribution %in% 
            c("negative binomial", "binomial", "poisson") && 
            any(na.omit(x[is.finite(x)] != as.integer(x[is.finite(x)])))) {
          stop(paste0("Non-integer values not allowed for ", distribution, 
            " distribution. "))
        }
      }
    }
    if (any(is.infinite(x))) {
      stop("Argument y must contain only finite or NA values.")
    }
  }
  x
}

check_distribution <- function(x, distribution) {
  for (i in seq_len(ncol(x))) {
    if (distribution[i] != "gaussian" && any(na.omit(x[, i]) < 0)) {
      stop(paste0("Negative values not allowed for ", distribution[i], 
        " distribution. "))
    } else {
      if (distribution[i] %in% 
          c("negative binomial", "binomial", "poisson") && 
          any(na.omit(x[, i] != as.integer(x[, i])))) {
        stop(paste0("Non-integer values not allowed for ", distribution[i], 
          " distribution. "))
      }
    }
  }
}
check_sd <- function(x, type, add_prefix = TRUE) {
  
  if (add_prefix) {
    param <- paste0("sd_", type)
  } else {
    param <- type
  }
  if (length(x) != 1) {
    stop(paste0("Argument ", param, " must be of length one."))
  }
  if (!is.numeric(x)) {
    stop(paste0("Argument ", param, " must be numeric."))
  }
  if (x < 0) {
    stop(paste0("Argument ", param, " must be non-negative."))
  }
  if (is.infinite(x)) {
    stop(paste0("Argument ", param, " must be finite."))
  }
  
}

check_xreg <- function(x, n) {
  
  if (!(nrow(x) %in% c(0, n))) {
    stop("Number of rows in xreg is not equal to the length of the series y.")
  }
  if (any(!is.finite(x))) {
    stop("Argument xreg must contain only finite values. ")
  }
  
}

check_beta <- function(x, k) {
  if(!is.numeric(x)) stop("'beta' must be numeric. ")
  if (length(x) != k) {
    stop(paste("Number of coefficients in beta is not equal to the number",
      "of columns of xreg.", sep = " "))
  }
  if (any(!is.finite(x))) {
    stop("Argument 'beta' must contain only finite values. ")
  }
  
}

check_mu <- function(x) {
  
  if (length(x) != 1) {
    stop(paste0("Argument 'mu' must be of length one."))
  }
  if (any(!is.finite(x))) {
    stop("Argument 'mu' must contain only finite values. ")
  }
  
}
check_rho <- function(x) {
  
  if (length(x) != 1) {
    stop(paste0("Argument 'rho' must be of length one."))
  }
  if (abs(x) >= 1) {
    stop("Argument 'rho' must be strictly between -1 and 1.")
  }
  
}
check_phi <- function(x, distribution) {
  if (x < 0) {
    stop("Parameter 'phi' must be non-negative.")
  }
}
check_u <- function(x, multivariate = FALSE) {
  if (any(x < 0)) {
    stop("All values of 'u' must be non-negative.")
  }
  if (multivariate) {
    if (!is.matrix(x) && !is.numeric(x)) {
      stop("Argument 'u' must be a numeric matrix or multivariate ts object.")
    }
  } else {
    if (!(is.vector(x) && !is.list(x)) && !is.numeric(x)) {
      stop("Argument 'u' must be a numeric vector or ts object.")
    }
  }
  if (any(is.infinite(x))) {
    stop("Argument 'u' must contain only finite values.")
  }
}
check_prior <- function(x, name) {
  if (!is_prior(x) && !is_prior_list(x)) {
    stop(paste(name, "must be of class 'bssm_prior' or 'bssm_prior_list'."))
  }
}

check_target <- function(target) {
  if (length(target) > 1 || target >= 1 || target <= 0) {
    stop("Argument 'target' must be on interval (0, 1).")
  }
}


check_D <- function(x, p, n) {
  if (missing(x) || is.null(x)) {
    x <- if (p == 1) 0 else matrix(0, p, 1)
  } else {
    if(!is.numeric(x)) stop("'D' must be numeric. ")
    if (p == 1) {
      if (!(length(x) %in% c(1, n))) {
        stop(paste("'D' must be a scalar or length n, where n is the number of",
          "observations.", sep = " "))
        x <- as.numeric(x)
      } 
    } else {
      if (is.null(dim(x)) || nrow(x) != p || !(ncol(x) %in% c(1, n))) {
        stop(paste("'D' must be p x 1 or p x n matrix, where p is the number",
          "of series.", sep = " "))
      } 
    }
  }
  x
}

check_C <- function(x, m, n) {
  if (missing(x) || is.null(x)) {
    x <- matrix(0, m, 1)
  } else {
    if(!is.numeric(x)) stop("'C' must be numeric. ")
    if (is.null(dim(x)) || nrow(x) != m || !(ncol(x) %in% c(1, n))) {
      stop(paste("'C' must be m x 1 or m x n matrix, where m is", 
        "the number of states.", sep = " "))
    } 
  }
  x
}

create_regression <- function(beta, xreg, n) {
  if (missing(xreg) || is.null(xreg)) {
    list(xreg = matrix(0, 0, 0), coefs = numeric(0), beta = NULL)
  } else {
    if (missing(beta) || is.null(beta)) {
      stop("No prior defined for beta. ")
    } else {
      if (!is_prior(beta) && !is_prior_list(beta)) {
        stop(paste("Prior for beta must be of class 'bssm_prior' or", 
          "'bssm_prior_list.", sep = " " ))
      } else {
        if (is.null(dim(xreg)) && length(xreg) == n) {
          dim(xreg) <- c(n, 1)
        }
        check_xreg(xreg, n)
        nx <- ncol(xreg)
        if (nx == 1 && is_prior_list(beta)) beta <- beta[[1]]
        if (nx > 1) {
          coefs <- vapply(beta, "[[", "init", FUN.VALUE = 1)
        } else {
          coefs <- beta$init
        }
        check_beta(coefs, nx)
        if (nx > 0 && is.null(colnames(xreg))) {
          colnames(xreg) <- paste0("coef_", seq_len(ncol(xreg)))
        }
        names(coefs) <- colnames(xreg)
      }
    }
    list(xreg = xreg, coefs = coefs, beta = beta)
  }
}

check_Z <- function(x, p, n, multivariate = FALSE) {
  if(!is.numeric(x)) stop("'Z' must be numeric. ")
  if (!multivariate) {
    if (length(x) == 1) {
      dim(x) <- c(1, 1)
    } else {
      if (!(dim(x)[2] %in% c(1, NA, n))) {
        stop(paste("'Z' must be a (m x 1) or (m x n) matrix, where",
          "m is the number of states and n is the length of the series. ",
          sep = " "))
      } else {
        dim(x) <- 
          c(dim(x)[1], (n - 1) * (max(dim(x)[2], 0, na.rm = TRUE) > 1) + 1)
      }
    } 
  } else {
    if(p == 1 && length(x) == 1) {
      dim(x) <- c(1, 1, 1)
    } else {
      if (is.null(dim(x)) || dim(x)[1] != p || !(dim(x)[3] %in% c(1, NA, n))) {
        stop(paste("'Z' must be a (p x m) matrix or (p x m x n) array",
          "where p is the number of series, m is the number of states,", 
          "and n is the length of the series. ", sep = " "))
      }
    }
    dim(x) <- 
      c(p, dim(x)[2], (n - 1) * (max(dim(x)[3], 0, na.rm = TRUE) > 1) + 1)
  }
  x
}

check_T <- function(x, m, n) {
  if(!is.numeric(x)) stop("'T' must be numeric. ")
  if (length(x) == 1 && m == 1) {
    dim(x) <- c(1, 1, 1)
  } else {
    if ((length(x) == 1) || any(dim(x)[1:2] != m) || 
        !(dim(x)[3] %in% c(1, NA, n))) {
      stop(paste("'T' must be a (m x m) matrix, (m x m x 1) or",
        "(m x m x n) array, where m is the number of states. ", sep = " "))
    }
    dim(x) <- c(m, m, (n - 1) * (max(dim(x)[3], 0, na.rm = TRUE) > 1) + 1)
  }
  x
}

check_R <- function(x, m, n) {
  if (length(x) == m) {
    dim(x) <- c(m, 1, 1)
  } else {
    if(!is.numeric(x)) stop("'R' must be numeric. ")
    if (!(dim(x)[1] == m) || dim(x)[2] > m || !dim(x)[3] %in% c(1, NA, n)) {
      stop(paste("'R' must be a (m x k) matrix, (m x k x 1) or", 
        "(m x k x n) array, where k<=m is the number of disturbances eta,", 
        "and m is the number of states. ", sep = " "))
    } else {
      dim(x) <- 
        c(m, dim(x)[2], (n - 1) * (max(dim(x)[3], 0, na.rm = TRUE) > 1) + 1)
    }
  }
  x
}

check_a1 <- function(x, m) {
  if (missing(x) || is.null(x)) {
    x <- numeric(m)
  } else {
    if(!is.numeric(x)) stop("'a1' must be numeric. ")
    if (length(x) == 1 || length(x) == m) {
      x <- rep(x, length.out = m)
    } else {
      stop(paste("Misspecified a1, argument a1 must be a vector of length m,",
        "where m is the number of state_names and 1<=t<=m.", sep = " "))
    }
  }
  x
}

check_P1 <- function(x, m) {
  if (missing(x) || is.null(x)) {
    x <- matrix(0, m, m)
  } else {
    if(!is.numeric(x)) stop("'P1' must be numeric. ")
    if (length(x) == 1 && m == 1) {
      dim(x) <- c(1, 1)
    } else {
      if (!identical(dim(x), c(m, m)))
        stop(paste("Argument P1 must be (m x m) matrix, where m is the number",
          "of states. ", sep = " "))
    }
  }
  x
}

check_H <- function(x, p, n, multivariate = FALSE) {
  
  if(!is.numeric(x)) stop("'H' must be numeric. ")
  
  if (!multivariate) {
    if (!(length(x) %in% c(1, n))) {
      stop(paste("'H' must be a scalar or length n, where n is the length of",
        "the time series y", sep = " "))
    } else x <- as.numeric(x)
  } else {
    if (any(dim(x)[1:2] != p) || !(dim(x)[3] %in% c(1, n, NA))) {
      stop(paste("'H' must be p x p matrix or p x p x n array, where p is the",
        "number of series and n is the length of the series.", sep = " "))
    } else {
      dim(x) <- c(p, p, (n - 1) * (max(dim(x)[3], 0, na.rm = TRUE) > 1) + 1)
    }
  }
  x
}

Try the bssm package in your browser

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

bssm documentation built on Sept. 6, 2021, 9:12 a.m.