Nothing
################################################################################
synonyms <- list(
poisson = "pois",
'negative-binomial' = "nbinom",
uniform = "unif",
laplace = "lapl",
logistic = "logis",
normal = "norm",
'normal-mixture' = "mixnorm",
'mixture-normal' = "mixnorm",
'two-piece-exponential' = "2pexp",
'two-piece-normal' = "2pnorm",
exponential = "exp",
'log-laplace' = "llapl",
'log-logistic' = "llogis",
'log-normal' = "lnorm"
)
# check existence of distribution family
#' @importFrom methods existsFunction
getFamily <- function(family, score) {
family <- unique(family)
ind <- match(family, names(synonyms), nomatch = 0L)
family[ind > 0L] <- synonyms[ind]
family <- unique(family)
n <- length(family)
if (n > 1) {
stop(sprintf("Ambiguous choice of parametric family - see details section of ?%s for a list of available choices.",
paste0(score, ".numeric")))
} else if (n == 0) {
stop(sprintf("Could not find parametric family - see details section of ?%s for a list of available choices.",
paste0(score, ".numeric")))
}
if (!existsFunction(paste0(score, "_", family)) ||
!existsFunction(paste0("check_", score, "_", family))) {
stop(sprintf("Could not find parametric family - see details section of ?%s for a list of available choices.",
paste0(score, ".numeric")))
}
return(family)
}
################################################################################
### general parametric checks
# for only one choice of parameterization
checkNames1 <- function(required, given) {
if (!all(required %in% given)) {
stop(paste("Missing parameter.",
paste("Given input:", paste(given, collapse=", ")),
paste("Required input:", paste(required, collapse=", ")),
sep="\n")
)
}
}
# for multiple parameterizations
checkNames2 <- function(required, given) {
ind <- lapply(required, `%in%`, given)
param.choice <- which(sapply(ind, all))
if (length(param.choice) > 1) {
stop(paste("Multiple parameterizations given. Please choose one.",
paste("Given input:", paste(given, collapse = ", ")),
paste("Required input:",
paste(lapply(required, paste, collapse = ", "),
collapse = " OR ")),
sep="\n")
)
} else if (length(param.choice) == 0) {
stop(paste("Missing parameter.",
paste("Given input:", paste(given, collapse = ", ")),
paste("Required input:",
paste(lapply(required, paste, collapse = ", "),
collapse = " OR ")),
sep="\n")
)
}
}
checkNames3 <- function(optional, given) {
ind <- match(optional, given, nomatch = 0)
if (any(ind != 0)) {
if (any(ind == 0)) {
stop(
paste(
"Missing parameter.",
paste("Given input:", paste(given, collapse = ", ")),
paste("Optional input:", paste(optional, collapse = ", ")),
"Using one of the optional parameters requires all of this group.",
sep = "\n"
)
)
} else {
return(TRUE)
}
} else {
return(FALSE)
}
}
checkNumeric <- function(input, infinite_exception = NULL) {
input_numeric <- sapply(input, is.numeric)
if (any(!input_numeric)) {
stop(paste("Non-numeric input:",
paste(names(input)[!input_numeric], collapse = ", ")))
}
input_NA <- sapply(input, anyNA)
if (any(input_NA)) {
stop(paste("Input with missing values:",
paste(names(input)[input_NA], collapse = ", ")))
}
input <- input[!names(input) %in% infinite_exception]
input_infinite <- sapply(input, function(x) any(is.infinite(x)))
if (any(input_infinite)) {
stop(paste("Input with infinite values:",
paste(names(input)[input_infinite], collapse = ", ")))
}
}
# for scalar or vectorial parameters
checkVector <- function(input) {
input_isvector <- sapply(input, is.vector)
if (any(!input_isvector)) {
stop(paste("Non-scalar or non-vectorial input:", paste(names(input)[!input_isvector], collapse=", ")))
}
input_lengths <- sapply(input, length)
input_maxlength <- max(input_lengths)
if (any(is.na(match(input_lengths, c(1, input_maxlength))))) {
stop("Incompatible input vector lengths. Each vector should be of length 1 or n.")
}
}
# for matrix parameters
checkMatrix <- function(input) {
if (!is.vector(input$y)) stop("Non-scalar or non-vectorial input: y")
input_ismatrix <- sapply(input[-1], is.matrix)
if (any(!input_ismatrix)) {
stop(paste("Non-matrix input:", paste(names(input[-1])[!input_ismatrix], collapse=", ")))
}
input_dims <- sapply(input[-1], dim)
ylength <- length(input$y)
input_maxdim <- c(ylength, max(input_dims[2,]))
if (any(is.na(sapply(1:2, function(i) match(input_dims[i,], input_maxdim[i]))))) {
stop("Incompatible input object sizes.")
}
}
check_sizes_VecMat <- function(input, types) {
stopifnot(all(types %in% c("vec", "mat")))
stopifnot(identical(length(input), length(types)))
input_isvector <- sapply(input[types == "vec"], is.vector)
input_ismatrix <- sapply(input[types == "mat"], is.matrix)
input_dim1 <- sapply(input, function(x) {
if (is.vector(x)) length(x) else dim(x)[1L]
})
input_dim2 <- sapply(input[types == "mat"], function(x) {
if (is.matrix(x)) dim(x)[2L]
})
if (!all(input_isvector) ||
!all(input_ismatrix) ||
!identical(length(unique(input_dim1)), 1L) ||
!identical(length(unique(input_dim2)), 1L)) {
reference_formats <- ifelse(types == "vec", "vector[1:n]", "matrix[1:n, 1:m]")
input_formats <- sapply(input, function(x) {
if (is.vector(x)) {
sprintf("vector[1:%i]", length(x))
} else if (is.matrix(x)) {
sprintf("matrix[1:%i, 1:%i]", dim(x)[1L], dim(x)[2L])
} else {
"unidentified"
}
})
stop(
paste(
"Incompatible input objects.",
sprintf("Expected input for (%s): %s.",
paste(names(input), collapse = ", "),
paste(reference_formats, collapse = ", ")),
sprintf(" Given input for (%s): %s.",
paste(names(input), collapse = ", "),
paste(input_formats, collapse = ", ")),
sep = "\n"
)
)
}
}
#### legacy checks ####
### logistic
check.logis <- function(input) {
required <- c("y", "location", "scale")
optional <- list(c("lower", "lmass"),
c("upper", "umass"))
checkNames1(required, names(input))
choice2 <- sapply(optional, checkNames3, names(input))
used <- c(required, optional[choice2])
input <- input[do.call(c, used)]
checkVector(input)
if (any(choice2)) {
checkNumeric(input[!names(input) %in% c("lmass", "umass")])
if (choice2[1] == TRUE) {
if (is.character(input$lmass)){
if (any(!input$lmass %in% c("trunc", "cens"))) {
stop("Valid character input for 'lmass': 'trunc', 'cens'")
}
} else if (!is.numeric(input$lmass)) {
stop("Type of 'lmass' is neither character nor numeric.")
} else {
if (any(input$lmass < 0 | input$lmass > 1)) {
stop("Parameter 'lmass' contains values not in [0, 1].")
}
}
}
if (choice2[2] == TRUE) {
if (is.character(input$umass)){
if (any(!input$umass %in% c("trunc", "cens"))) {
stop("Valid character input for 'lmass': 'trunc', 'cens'")
}
} else if (!is.numeric(input$umass)) {
stop("Type of 'umass' is neither character nor numeric")
} else {
if (any(input$umass < 0 | input$umass > 1)) {
stop("Parameter 'umass' contains values not in [0, 1].")
}
}
}
if (sum(choice2) == 2) {
if (any(input$lower > input$upper)) {
stop("Parameter 'lower' contains values greater than parameter 'upper'.")
}
}
} else {
checkNumeric(input)
}
if (any(is.infinite(input$location))) stop("Parameter 'location' contains infinite values.")
if (any(!input$scale>0)) stop("Parameter 'scale' contains non-positive values.")
if (any(is.infinite(input$scale))) stop("Parameter 'scale' contains infinite values.")
return(input)
}
### normal
check.norm <- function(input) {
required <- list(c("y", "mean", "sd"),
c("y", "location", "scale"))
optional <- list(c("lower", "lmass"),
c("upper", "umass"))
choice <- checkNames2(required, names(input)) # object type: integer
choice2 <- sapply(optional, checkNames3, names(input)) # object type: logical
used <- c(required[choice], optional[choice2]) # object type: list
input <- input[do.call(c, used)]
checkVector(input)
if (any(choice2)) {
checkNumeric(input[!names(input) %in% c("lmass", "umass")])
if (choice2[1] == TRUE) {
if (is.character(input$lmass)){
if (any(!input$lmass %in% c("trunc", "cens"))) {
stop("Valid character input for 'lmass': 'trunc', 'cens'")
}
} else if (!is.numeric(input$lmass)) {
stop("Type of 'lmass' is neither character nor numeric.")
} else {
if (any(input$lmass < 0 | input$lmass > 1)) {
stop("Parameter 'lmass' contains values not in [0, 1].")
}
}
}
if (choice2[2] == TRUE) {
if (is.character(input$umass)){
if (any(!input$umass %in% c("trunc", "cens"))) {
stop("Valid character input for 'lmass': 'trunc', 'cens'")
}
} else if (!is.numeric(input$umass)) {
stop("Type of 'umass' is neither character nor numeric")
} else {
if (any(input$umass < 0 | input$umass > 1)) {
stop("Parameter 'umass' contains values not in [0, 1].")
}
}
}
if (sum(choice2) == 2) {
if (any(input$lower > input$upper)) {
stop("Parameter 'lower' contains values greater than parameter 'upper'.")
}
}
} else {
checkNumeric(input)
}
if (choice == 1) {
if (any(is.infinite(input$mean))) stop("Parameter 'mean' contains infinite values.")
if (any(!input$sd>0)) stop("Parameter 'sd' contains non-positive values.")
if (any(is.infinite(input$sd))) stop("Parameter 'sd' contains infinite values.")
names(input)[names(input) == "mean"] <- "location"
names(input)[names(input) == "sd"] <- "scale"
} else if (choice == 2) {
if (any(is.infinite(input$location))) stop("Parameter 'location' contains infinite values.")
if (any(!input$scale>0)) stop("Parameter 'scale' contains non-positive values.")
if (any(is.infinite(input$scale))) stop("Parameter 'scale' contains infinite values.")
}
return(input)
}
### t
check.t <- function(input) {
required <- c("y", "df", "location", "scale")
optional <- list(c("lower", "lmass"),
c("upper", "umass"))
checkNames1(required, names(input))
choice2 <- sapply(optional, checkNames3, names(input))
used <- c(required, optional[choice2])
input <- input[do.call(c, used)]
checkVector(input)
if (any(choice2)) {
checkNumeric(input[!names(input) %in% c("lmass", "umass")])
if (choice2[1] == TRUE) {
if (is.character(input$lmass)){
if (any(!input$lmass %in% c("trunc", "cens"))) {
stop("Valid character input for 'lmass': 'trunc', 'cens'")
}
} else if (!is.numeric(input$lmass)) {
stop("Type of 'lmass' is neither character nor numeric.")
} else {
if (any(input$lmass < 0 | input$lmass > 1)) {
stop("Parameter 'lmass' contains values not in [0, 1].")
}
}
}
if (choice2[2] == TRUE) {
if (is.character(input$umass)){
if (any(!input$umass %in% c("trunc", "cens"))) {
stop("Valid character input for 'lmass': 'trunc', 'cens'")
}
} else if (!is.numeric(input$umass)) {
stop("Type of 'umass' is neither character nor numeric")
} else {
if (any(input$umass < 0 | input$umass > 1)) {
stop("Parameter 'umass' contains values not in [0, 1].")
}
}
}
if (sum(choice2) == 2) {
if (any(input$lower > input$upper)) {
stop("Parameter 'lower' contains values greater than parameter 'upper'.")
}
}
} else {
checkNumeric(input)
}
if (any(!input$df>0)) stop("Parameter 'df' contains non-positive values.")
if (any(is.infinite(input$location))) stop("Parameter 'location' contains infinite values.")
if (any(!input$scale>0)) stop("Parameter 'scale' contains non-positive values.")
if (any(is.infinite(input$scale))) stop("Parameter 'scale' contains infinite values.")
return(input)
}
### normal-mixture
check.mixnorm <- function(input) {
required <- c("y", "m", "s", "w")
optional <- c("exact", "rel.tol")
checkNames1(required, names(input))
checkMatrix(input[required])
ind <- sapply(optional, checkNames3, names(input))
input <- input[c(required, optional[ind])]
if (ind[2] == TRUE) {
if (length(input$rel.tol) != 1) {
stop("Parameter 'rel.tol' needs to be of length 1.")
}
}
if (ind[1] == TRUE) {
if (length(input$exact) != 1) {
stop("Parameter 'exact' needs to be of length 1.")
}
if (!input$exact %in% c(TRUE, FALSE)) {
stop("Parameter 'exact' needs to be TRUE or FALSE.")
}
checkNumeric(input[names(input) != "exact"])
} else {
checkNumeric(input)
}
if (any(is.infinite(input$m))) stop("Parameter 'm' contains infinite values.")
if (any(!input$s>0)) stop("Parameter 's' contains non-positive values.")
if (any(is.infinite(input$s))) stop("Parameter 's' contains infinite values.")
if (any(input$w < 0 | input$w > 1)) stop("Parameter 'w' contains values not in [0, 1].")
if (all.equal(apply(input$w, 1, sum), rep(1, dim(input$w)[1])) != TRUE) stop("Parameter 'w' contains weighting schemes which do not sum up to 1.")
return(input)
}
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.