Nothing
# ==============================================================================
# quickblock -- Quick Threshold Blocking
# https://github.com/fsavje/quickblock
#
# Copyright (C) 2017 Fredrik Savje, Jasjeet Sekhon, Michael Higgins
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see http://www.gnu.org/licenses/
# ==============================================================================
# ==============================================================================
# Helper functions
# ==============================================================================
# Throw error
new_error <- function(..., level = -2) {
stop(structure(list(message = paste0(...),
call = match.call(definition = sys.function(level),
call = sys.call(which = level),
expand.dots = TRUE,
envir = sys.frame(level - 1))),
class = c("error", "condition")))
}
# Throw warning
new_warning <- function(..., level = -2) {
warning(structure(list(message = paste0(..., level = -2),
call = match.call(definition = sys.function(level),
call = sys.call(which = level),
expand.dots = TRUE,
envir = sys.frame(level - 1))),
class = c("warning", "condition")))
}
# Is `x` a numeric that can be coerced into integer without loss of information?
is.numeric_integer <- function(x) {
is.numeric(x) &&
!any(is.nan(x)) &&
!any(is.infinite(x)) &&
all(is.na(x) | as.integer(x) == x)
}
# ==============================================================================
# Ensure functions
# ==============================================================================
# Ensure that `blocking` is a `scclust` object
ensure_blocking <- function(blocking,
req_length = NULL) {
if (!scclust::is.scclust(blocking)) {
new_error("`", match.call()$blocking, "` is not a valid blocking object.")
}
if (!is.null(req_length) && (length(blocking) != req_length)) {
new_error("`", match.call()$blocking, "` does not contain `", match.call()$req_length, "` units.")
}
}
# Ensure `caliper` is NULL or a scalar, positive, non-na, numeric
ensure_caliper <- function(caliper) {
if (!is.null(caliper)) {
if (length(caliper) != 1L) {
new_error("`", match.call()$caliper, "` must be scalar.")
}
if (is.na(caliper)) {
new_error("`", match.call()$caliper, "` may not be NA.")
}
if (!is.numeric(caliper)) {
new_error("`", match.call()$caliper, "` must be numeric or `NULL`.")
}
if (caliper <= 0.0) {
new_error("`", match.call()$caliper, "` must be positive or `NULL`.")
}
}
}
# Ensure that `distances` is `distances` object
ensure_distances <- function(distances) {
if (!distances::is.distances(distances)) {
new_error("`", match.call()$distances, "` is not a `distances` object.")
}
}
# ==============================================================================
# Coerce functions
# ==============================================================================
# Coerce `x` to double
coerce_double <- function(x, req_length = NULL) {
if (!is.double(x)) {
if (is.numeric(x)) {
x <- as.double(x)
} else {
new_error("`", match.call()$x, "` is not numeric.")
}
}
if (!is.null(req_length) && (length(x) != req_length)) {
new_error("`", match.call()$x, "` is not of length `", match.call()$req_length, "`.")
}
x
}
# Coerce `size_constraint` to scalar, non-NA integer with default as `sum(type_constraints)`
coerce_size_constraint <- function(size_constraint,
num_data_points) {
if (is.null(size_constraint)) {
new_error("`", match.call()$size_constraint, "` cannot be NULL.")
}
if (length(size_constraint) != 1L) {
new_error("`", match.call()$size_constraint, "` must be scalar.")
}
if (!is.integer(size_constraint)) {
if (is.numeric_integer(size_constraint)) {
storage.mode(size_constraint) <- "integer"
} else {
new_error("`", match.call()$size_constraint, "` must be integer.")
}
}
if (is.na(size_constraint)) {
new_error("`", match.call()$size_constraint, "` may not be NA.")
}
if (size_constraint < 2L) {
new_error("`", match.call()$size_constraint, "` must be greater or equal to two.")
}
if (size_constraint > num_data_points) {
new_error("`", match.call()$size_constraint, "` may not be great than the number of units.")
}
size_constraint
}
# Coerce `treatments` to factor
coerce_treatments <- function(treatments,
req_length = NULL) {
if (!is.factor(treatments)) {
if (!is.vector(treatments)) {
new_error("Do not know how to coerce `", match.call()$treatments, "` to factor.")
}
if (!is.integer(treatments) && !is.logical(treatments) && !is.character(treatments)) {
new_warning("Coercing `", match.call()$treatments, "` to factor.")
}
treatments <- as.factor(treatments)
}
if (nlevels(treatments) < 2L) {
new_error("`", match.call()$treatments, "` must contain at least two treatment conditions.")
}
if (!is.null(req_length) && (length(treatments) != req_length)) {
new_error("Length of `", match.call()$treatments, "` is incorrect.")
}
treatments
}
# Coerce `treatment_names` to character vector
coerce_treatment_names <- function(treatment_names) {
if (!is.vector(treatment_names)) {
new_error("`", match.call()$treatment_names, "` must be vector.")
}
if (!is.character(treatment_names)) {
treatment_names <- as.character(treatment_names)
}
if (anyDuplicated(treatment_names)) {
new_error("`", match.call()$treatment_names, "` may not contain duplicates.")
}
if (any(is.na(treatment_names))) {
new_error("`", match.call()$treatment_names, "` may not contain NAs.")
}
if (length(treatment_names) <= 1L) {
new_error("`", match.call()$treatment_names, "` must contain at least two treartments.")
}
treatment_names
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.