Nothing
## - | FILE HEADER |
##
## Script name:
## args_validation.R
##
## Purpose of script:
## implements various functions to perform the validation of the various
## arguments of the functions contained in the package, it contains two
## list of functions: one called 'check' that checks for the existence,
## and validity of arguments (ranges, controls, args, hyperparams, layers,
## xtraclusters, and args), and a list called 'validation' that is performs
## the validation of invidual arguments in terms of type, and range, and it
## is called by the function .xcheck$onearg (in turn called by .xcheck$args).
##
##
## Author:
## Montasser Ghachem
##
## Last updated:
## 2023-03-20
##
## License:
## GPL 3
##
## Email:
## montasser.ghachem@pinstimation.com
##
##
##
##
## ++++++++++++++++++
##
## Notes:
##
## Package PINstimation
## website: www.pinstimation.com
## Authors: Montasser Ghachem and Oguz Ersan
## +++++++++++++++++++++++++
## ++++++| | PRIVATE FUNCTIONS | |
## +++++++++++++++++++++++++
.xcheck <- list(
hyperparams = function(hyperparams, days, adj = FALSE) {
# computes a set of hyperparameters for the ECM estimation
#
# Args:
# hyperparams : a list of hyperparameters entered by user
# days : the number of days in the dataset
# adj : takes TRUE when the call of the function comes
# : from the function adjpin()
#
# Returns:
# a list of valid hyperparameters
default <- .default$hyperparams(adj)
defaultbounds <- .default$hyperbounds(adj)
minv <- defaultbounds$minv
maxv <- defaultbounds$maxv
# Before checking the hyperparameters, let's check if hyperparams has
# unrecognized or duplicated keys
rkeys <- names(hyperparams)
keys <- c("criterion", "minalpha", "tolerance", "maxeval",
"maxlayers", "maxinit")
if (adj) keys <- c("tolerance", "maxeval")
unknown <- setdiff(rkeys, keys)
if (length(unknown) > 0)
return(list(off = TRUE, error = uierrors$hyperparams(
error = "unrecognized", varname = unknown)))
# Check if 'hyperparams' does not have duplicates (error code: 7)
# -------------------------------------------------------------
iserror <- any(duplicated(rkeys) == TRUE)
isvars <- rkeys[duplicated(rkeys)]
if (iserror)
return(list(off = TRUE, error = uierrors$hyperparams(
error = "duplicate", varname = keys[which(keys == isvars)])))
# If the list 'control' is empty, return default values
keys <- names(default)
if (length(hyperparams) == 0)
return(list(off = FALSE, hyperparams = default))
# If the list 'hyperparams' is not empty.
# Set the new_hps values at the default value, and replace
# them with the values in the list 'hyperparams' if corresponding values
# exist, and are valid
new_hps <- default
# Check if there any unrecognized keys
# -------------------------------------------------------------
rkeys <- names(hyperparams)
common <- length(intersect(rkeys, keys))
# Check that all hyperparams are numeric (except criterion)
# -------------------------------------------------------------
temphps <- hyperparams
if (!is.null(temphps$criterion)) temphps$criterion <- NULL
if (length(temphps) > 0) {
is_numeric <- vapply(temphps, is.numeric, logical(1))
if (prod(is_numeric) == 0) {
# which key(s) is not numeric
wkey <- which(is_numeric == FALSE)[1]
var <- which(keys == names(temphps)[[wkey]])
addin <- 0 + !adj
return(list(off = TRUE, error = uierrors$hyperparams(
error = "notnumeric",
varname = keys[var], val = class(hyperparams[[addin + wkey]]))))
}
}
if (!is.null(hyperparams$criterion) && !is.character(hyperparams$criterion))
return(list(off = TRUE, error = uierrors$hyperparams(
error = "notcharacter",
varname = "criterion", val = class(hyperparams$criterion))))
names(hyperparams) <- rkeys
# Go over the keys of the list hyperparams as found in the default
# list, check they satisfy the validity conditions
# -------------------------------------------------------------
common <- sort(match(rkeys, keys))
for (k in common) {
iserror <- 0
key <- keys[[k]]
if (!adj && k == 1) {
if (!(toupper(hyperparams$criterion) %in% .default$criterion)) {
return(list(off = TRUE, error = uierrors$hyperparams(
error = "charrange", varname = key, val = hyperparams$criterion)))
next
}
}
hp <- unname(unlist(hyperparams[key]))
canbezero <- (k == 2)
# minalpha can be set to zero
# Check that the values are within the min-max bounds
# -----------------------------------------------------------------
in_bounds <- ux$is_sub(hp, c(minv[k], maxv[k]))
int_bounds <- ux$is.integer(hp) & in_bounds
if (adj) {
if (k == 1 && !in_bounds)
return(list(off = TRUE, error = uierrors$hyperparams(
error = "interval", varname = key, val = hp)))
if (k == 2 && !int_bounds)
return(list(off = TRUE, error = uierrors$hyperparams(
error = "intrange", varname = key, val = hp)))
} else {
# if the variables 'minalpha' and 'tolerance' then it is not an
# integer, we just need to check the bounds (in_bounds)
# The error code is 3 when 'minalpha', and is equal to 4 when
# 'tolerance' because tolerance is bounded away from zero
if (k %in% c(2, 3) && !in_bounds)
return(list(off = TRUE, error = uierrors$hyperparams(
error = "interval", varname = key, val = hp)))
# if the variables 'maxeval', 'maxlayers', and 'maxinit' then it
# must be an integer, so we need to check the bounds (int_bounds)
if (k %in% c(4, 5, 6) && !int_bounds)
return(list(off = TRUE, error = uierrors$hyperparams(
error = "intrange", varname = key, val = hp)))
}
# If no error, assign the value of 'hp' to the list new_hps
# -----------------------------------------------------------------
new_hps[key] <- list(hp)
}
return(list(off = FALSE, hyperparams = new_hps))
},
existence = function(d, err) {
# Check whether the object 'object' exists
#
# Args:
# object: an R object (mostly a dataframe in our case)
#
# Returns:
# NULL if the object exists, otherwise an error message.
errors <- uierrors$arguments()
for (i in seq_len(length(d))) {
tryCatch({
suppressWarnings(get0(d[i]))
xlist <- list(off = FALSE, error = "")
}, error = function(cond) {
msg <- unlist(strsplit(toString(cond), ": "))[[2]]
xlist <- list(off = TRUE, error = errors$notfound(d[i], msg))
ux$stopnow(xlist$off, m = xlist$error, err)
})
}
},
ranges = function(ranges, adj = FALSE) {
# checks the provided ranges by the user as argument in the functions
# generatedata_mpin() and generatedata_adjpin(), and returns the ranges
# to be used by these functions
#
# Args:
# ranges : a list of ranges for the different model parameters
# adj : if TRUE, the model in question is Duarte and Young (2009),
# : otherwise, it is MPIN of Ersan (2016)
#
# Returns:
# NULL if one of more ranges are not valid, otherwise, a list of valid
# ranges for the parameters.
# load default ranges, and rangebounds using the function .default
# ------------------------------------------------------------------
model <- ifelse(adj, "adjpin", "mpin")
default <- .default$ranges(model = model)
defaultbounds <- .default$rangebounds(model = model)
minv <- defaultbounds$minv
maxv <- defaultbounds$maxv
probk <- defaultbounds$probk
keys <- names(default)
new_ranges <- list()
# If the list 'ranges' is empty, return default values
if (length(ranges) == 0) return(list(off = FALSE, ranges = default))
# If the list 'ranges' is not empty.
# Set the new_ranges values at the default value, and replace
# them with the values in the list 'ranges' if corresponding values
# exist, and are valid
new_ranges <- default
rkeys <- names(ranges)
iserror <- 0
# Check that all control variables are numeric (error code: 1)
# -------------------------------------------------------------
is_numeric <- vapply(ranges, is.numeric, logical(1))
if (prod(is_numeric) == 0) {
# which key(s) is not numeric
wkey <- which(is_numeric == FALSE)[1]
return(list(off = TRUE, error = uierrors$ranges(
var = names(ranges)[[wkey]], val = ranges[[wkey]], code = 1)))
}
is_numeric <- prod(vapply(ranges, is.numeric, logical(1)))
if (!is_numeric) return(list(off = TRUE, error = uierrors$ranges(code = 1)))
allerrors <- list()
allvars <- list()
# Check if 'ranges' does not have duplicates (error code: 4)
# -------------------------------------------------------------
iserror <- any(duplicated(rkeys) == TRUE) * 4
isvars <- rkeys[duplicated(rkeys)]
allerrors <- c(allerrors, list(iserror))
allvars <- c(allvars, list(isvars))
# Check if there any unrecognized keys (error code: 5)
# -------------------------------------------------------------
common <- length(intersect(rkeys, keys))
iserror <- iserror + (iserror == 0) * (length(rkeys) != common) * 5
isvars <- setdiff(rkeys, keys)
allerrors <- c(allerrors, list(iserror))
allvars <- c(allvars, list(isvars))
# Check that not theta and thetap are both one (error code: 6)
# -------------------------------------------------------------
if (!is.null(ranges$theta) & !is.null(ranges$thetap)) {
iserror <- iserror + (iserror == 0) *
(min(ranges$theta) == 1 & min(ranges$thetap) == 1) * 6
allerrors <- c(allerrors, list(iserror))
allvars <- c(allvars, list(NULL))
}
founderrors <- unlist(allerrors)
if (length(which(founderrors > 0)) > 0) {
iserror <- allerrors[[which(founderrors > 0)[1]]]
isvars <- allvars[[which(founderrors > 0)[1]]]
return(list(off = TRUE, error = uierrors$ranges(isvars, code = iserror)))
}
ranges <- lapply(ranges, function(x)
if (length(x) == 1) c(x[1], x[1]) else x[1:2])
names(ranges) <- rkeys
# Go over the keys of the list ranges as found in the default
# list, check they satisfy the validity conditions
# -------------------------------------------------------------
common <- sort(match(rkeys, keys))
for (k in common) {
iserror <- 0
key <- keys[[k]]
isprob <- ifelse(k <= probk, TRUE, FALSE)
rng <- unname(unlist(ranges[key]))
# Check that all ranges values are within the min-max bounds
# The ranges of alpha (k ==1) is (0, 1); otherwise, the ranges of
# other variables should be are of the form [minv, maxv]
# -----------------------------------------------------------------
if (k == 1 && rng[1] == rng[2])
in_bounds <- (ux$strict_sub(rng, c(minv[k], maxv[k])))
if ((k == 1 && rng[1] < rng[2]) | k != 1)
in_bounds <- (ux$is_sub(rng, c(minv[k], maxv[k])))
# If is_bounds == FALSE, then return the error
# The parameters are probabilities when isprob = TRUE (error code: 2)
# The parameters are trade rates when isprob = FALSE (error code: 3)
# -----------------------------------------------------------------
iserror <- (!in_bounds) * isprob * 2 + (!in_bounds) * (!isprob) * 3
if (rng[1] > rng[2]) {
iserror <- isprob * 2 + (!isprob) * 3
}
new_ranges[key] <- list(rng)
if (iserror != 0) return(list(
off = TRUE,
error = uierrors$ranges(var = keys[[k]], code = iserror, val = rng)))
}
return(list(off = FALSE, ranges = new_ranges))
},
controls = function(control, vargs) {
# checks the provided controls by the user as argument in the function
# generatedata_mpin(), and, if they are valid, returns the controls
# to be used by the function.
#
# Args:
# control : a list of numbers controlling the relationship between
# the different model parameters in MPIN of Ersan(2016)
# vargs : list of arguments in ... for the function generatedata_mpin()
#
# Returns:
# NULL if one of more controls are not valid, otherwise, a list of valid
# controls.
# load default controls, and controlbounds using the function .default
# The keys' order: eps_ratio, mu_ratio, maxlayers, confidence, overlap
# ------------------------------------------------------------------
default <- .default$controls()
defaultbounds <- .default$controlbounds()
minv <- defaultbounds$minv
maxv <- defaultbounds$maxv
# Before checking the controls, let's check if vargs has unrecognized
# or duplicated keys
rkeys <- names(vargs)
keys <- c("confidence", "maxlayers", "eps_ratio", "mu_ratio")
unknown <- setdiff(rkeys, keys)
if (length(unknown) > 0)
return(list(off = TRUE, error = uierrors$controls(
var = unknown, code = 1, keys = keys)))
# Check if 'ranges' does not have duplicates (error code: 7)
# -------------------------------------------------------------
iserror <- any(duplicated(rkeys) == TRUE) * 7
isvars <- rkeys[duplicated(rkeys)]
if (iserror != 0)
return(list(off = TRUE, error = uierrors$controls(
var = which(keys == isvars), code = iserror, keys = keys)))
# If the list 'control' is empty, return default values
keys <- names(default)
if (length(control) == 0) return(list(off = FALSE, controls = default))
# If the list 'control' is not empty.
# Set the new_control values at the default value, and replace
# them with the values in the list 'control' if corresponding values
# exist, and are valid
new_control <- default
# Check if there any unrecognized keys
# -------------------------------------------------------------
rkeys <- names(control)
common <- length(intersect(rkeys, keys))
# Check that all control variables are numeric
# -------------------------------------------------------------
is_numeric <- vapply(control, is.numeric, logical(1))
if (prod(is_numeric) == 0) {
# which key(s) is not numeric
wkey <- which(is_numeric == FALSE)[1]
var <- which(keys == names(control)[[wkey]])
return(list(off = TRUE, error = uierrors$controls(
var = var, val = control[[wkey]], code = 2, keys = keys)))
}
control <- lapply(control, function(x)
if (length(x) == 1) c(x[1], x[1]) else x[1:2])
names(control) <- rkeys
# Go over the keys of the list control as found in the default
# list, check they satisfy the validity conditions
# -------------------------------------------------------------
common <- sort(match(rkeys, keys))
for (k in common) {
iserror <- 0
key <- keys[[k]]
ctrl <- unname(unlist(control[key]))
canbezero <- (k == 1 | k == 4)
strict <- (k == 2 | k == 4)
# Confidence level or eps.ratio can be deactivated when set to zero
# Check that the values are within the min-max bounds
# -----------------------------------------------------------------
if (!(canbezero & (ctrl[1] == 0))) {
in_bounds <- strict * (ux$strict_sub(ctrl, c(minv[k], maxv[k])))
in_bounds <- in_bounds +
(!strict) * (ux$is_sub(ctrl, c(minv[k], maxv[k])))
int_bounds <- in_bounds * (ctrl[1] == floor(ctrl[1]))
# If is_bounds == FALSE, then return the error
# Check that the argument 'maxlayers' is an integer
# -----------------------------------------------------------------
iserror <- (!int_bounds) * (k == 3) * 3
iserror <- iserror + (iserror == 0) * (!in_bounds) * (4 + canbezero)
# If iserror is zero, check that the elements of the argument
# 'eps.ratio' are increasing
# -----------------------------------------------------------------
iserror <- iserror + (iserror == 0) * (k == 1) *
(ctrl[2] < ctrl[1]) * 6
}
# The size of 'mu_ratio', 'maxlayers', and 'confidence' is 1
# -----------------------------------------------------------------
if (k %in% c(2, 3, 4)) ctrl <- ctrl[1] else {
if (ctrl[1] == ctrl[2]) ctrl <- ctrl[1]
}
# Assign the value of 'ctrl' to the list new_control
# -----------------------------------------------------------------
new_control[key] <- list(ctrl)
if (iserror != 0)
return(list(off = TRUE, error = uierrors$controls(
var = k, val = ctrl, code = iserror, keys = keys)))
}
return(list(off = FALSE, controls = new_control))
},
layers = function(minalpha, xlayers, layers, maxlayers, days) {
# samples the number of layers to be used to generate data using the
# .generate_data() function.
#
# Args:
# minalpha : lowest value in the alpha range
# xlayers : number of layers derived from the parameters
# layers : number of layers provided by the users
# maxlayers : maximum number of layers either provided by the user
# : or taking its default value '5'
# days : number of days for the generated data, either provided
# : by the user or taking its default value '60'.
#
# Returns:
# NULL if it is impossive to select a number of layers using the provided
# arguments, otherwise, a valid number of layers
args <- list(days = days, minalpha = minalpha, layers = layers)
# Check the different case to find the value of 'layers'
# --------------------------------------------------------------------------
alayers <- 1 / (minalpha + 10^ (-5))
if (!is.null(layers)) {
if (!is.numeric(layers)) return(uierrors$layers(code = 5, args))
if (layers < 0 | floor(layers) != layers)
return(uierrors$layers(code = 5, args))
if (xlayers != 0) {
if (xlayers != layers) cat(uierrors$layers(code = 1, args))
layers <- xlayers
}
if (layers >= days) return(uierrors$layers(code = 2, args))
if (layers > alayers) return(uierrors$layers(code = 3, args))
}
if (is.null(layers) & maxlayers > alayers) {
ux$show(m = uierrors$layers(code = 4, args), warning = TRUE, skip = FALSE)
maxlayers <- alayers
}
if (is.null(layers)) {
return(sample(maxlayers, 1))
} else {
return(layers)
}
},
xclusters = function(n, xtra, lay =1, adj = FALSE) {
err <- uierrors$arguments()
if (adj == F) {
# Make sure that 1 + xtraclusters + layers <= n, since the clustering
# algorithm of initial sets generation encoded in initials_mpin will
# cluster the data into 1 + xtraclusters + layers
valid <- (1 + xtra + lay <= n)
if (!valid)
return(list(off = TRUE, error = err$compatibility(
model = "mpin", n = n, cl = 1 + xtra + lay)))
return(list(off = FALSE, feedback = ""))
} else {
# Make sure that 6 + xtraclusters <= n, since the clustering algorithm
# of Adjpin initial sets generation encoded in initials_mpin will
# cluster the data into 6 + xtraclusters
valid <- (6 + xtra <= n)
if (!valid)
return(list(off = TRUE, error = err$compatibility(
model = "adjpin", n = n, cl = 6 + xtra)))
return(list(off = FALSE, feedback = ""))
}
},
args = function(arglist, fn) {
xnames <- names(arglist)
arglist$fn <- fn
for (i in seq_len(length(xnames))) {
rst <- .xcheck$onearg(xnames[i], arglist)
if (rst$off) return(rst)
}
return(list(off = FALSE, error = ""))
},
onearg = function(vn, al) {
# vn: variable name
# al: argument list
errors <- uierrors$arguments()
# determine the function, and the argument needed given the variable name vn
# default arguments to send to the function
# Eventually other elements will be added
vargs <- list(var = al[[vn]], name = vn, errors = errors)
# fn: denotes the function that call .xcheck$args
if (vn == "fn") return(list(off = FALSE, error = ""))
if (vn %in% c(
"tradinghours", "samplength", "buckets", "timebarsize", "num_init",
"xtraclusters", "layers", "grid_size", "series", "days", "timelag",
"sweeps", "prior.a", "prior.b", "unit")
) {
gn <- "xinteger"
vargs$range <- .default[[vn]]
}
if (vn == "confidence") {
gn <- "xnumeric"
vargs$range <- .default[[vn]]
vargs$strict <- TRUE
}
if (vn %in% c(
"fact", "verbose", "is_parallel", "correction", "ea_correction",
"fullreport")) gn <- "xlogical"
if (vn %in% c("algorithm", "method", "detectlayers", "factorization", "frequency")) {
gn <- "xcharacter"
vargs$range <- .default[[vn]]
}
if (vn %in% c("ranges", "hyperparams")) gn <- "xlist"
if (vn %in% c("data", "initialsets", "restricted", "parameters", "burnin")) {
gn <- vn
vargs$al <- al
}
xresult <- .xvalidate[[gn]](vargs)
return(xresult)
}
)
.xvalidate <- list(
initialsets = function(vargs) {
v <- vargs$al
err <- vargs$errors
vis <- v$initialsets
is_df <- is.data.frame(vis)
is_char <- is.character(vis)
# Account for the case where there is only one initialset
is_num <- is.numeric(vis)
if (!is.null(vis) & !is_df & !is_char & !is_num) {
return(list(off = TRUE, error = err$initials(
error = "wrongtype", class = class(vis))))
}
# Check that the dataframe initialsets has the correct number of
# variables
if (is_df | is_num) {
if (v$fn == "adjpin") {
goodsize <- 10 - sum(unlist(v$restricted))
xsize <- ifelse(is_df, ncol(vis), length(vis))
if (xsize != goodsize) {
return(list(off = TRUE, error = err$initials(
error = "wrongsize", cols = xsize,
rvars = goodsize)))
}
isprob <- ifelse(ux$is.logical(v$restricted$theta),
1:(4 - v$restricted$theta), 1:4)
probvalues <- ifelse(
is_df, vis[, isprob], vis[1:isprob])
invalid <- (
any(vis < 0) | !is.null(v$restricted$theta) &&
any(probvalues > 1))
if (invalid)
return(list(off = TRUE, error = err$initials(
error = "wrongvalues")))
}
if (v$fn == "mpin" | v$fn == "pin") {
xsize <- ifelse(is_df, ncol(vis), length(vis))
m <- (xsize - 2) / 3
if (!ux$integer(m) || m == 0)
return(list(off = TRUE, error = err$initials(
error = "wronglength", cols = xsize)))
not_prob <- ifelse(
is_df, any(vis[, 1:(2 * m)] > 1),
any(vis[1:(2 * m)] > 1))
if (any(vis < 0) | not_prob)
return(list(off = TRUE, error = err$initials(
error = "wrongvalues")))
}
} else {
if (v$fn == "adjpin") {
if (is_char && !any(toupper(vis) %in% .default$initialsets))
return(list(off = TRUE, error = err$initials(
error = "wrongalgorithm", unknown = toupper(vis))))
}
if (v$fn == "pin" && is.null(vis)) {
return(list(off = TRUE, error = err$initials(
error = "wrongtype", class = class(vis))))
}
}
return(list(off = FALSE, error = ""))
},
data = function(vargs) {
v <- vargs$al
err <- vargs$errors
if (v$fn == "aggregation" | v$fn == "vpin") {
if (!is.data.frame(v$data) & !is.matrix(v$data)) {
return(
list(off = TRUE,
error = err$hfdata(
error = "wrongclass",
class = class(v$data)
)
)
)
}
limit <- ifelse(v$fn == "vpin", 3, 4)
if (ncol(v$data) < limit) {
return(
list(off = TRUE,
error = err$hfdata(
error = "fewvariables",
cols = ncol(v$data),
limit = limit)
)
)
}
if (!ux$is.timestamp(v$data[, 1])) {
return(
list(off = TRUE,
error = err$hfdata(
error = "nottimestamp",
type1 = typeof(v$data[, 1]))
)
)
}
# Try to convert some values of the first column into a date variable
.sample <- sample(seq_len(nrow(v$data)), min(nrow(v$data) / 10, 100))
convertible <- vapply(
v$data[.sample, 1], ux$is.convertible.to.date, logical(1))
if (!all(convertible)) {
.failed <- which(convertible == FALSE)[[1]]
return(
list(off = TRUE,
error = err$hfdata(
error = "notdate",
failure = .failed)
)
)
}
# delete NA values from v$data
v$data <- na.omit(v$data)
# set add-on error code based on the type of the call: "aggregation" or "vpin"
addon <- ifelse(v$fn == "aggregation", "agg", "vpin")
numbers_only <- function(x) suppressWarnings(all(!is.na(as.numeric(x)))) #sapply(x, function(y) !grepl("\\D", y)))
.types <- vapply(2:limit, function(x) numbers_only(v$data[, x]), logical(1))
dtypes <- vapply(2:limit, function(x) typeof(v$data[, x]), character(1))
if (!all(.types)) {
return(
list(off = TRUE,
error = err$hfdata(
error = paste("wrongdatatypes_", addon, sep=""),
dtypes = dtypes)
)
)
}
colms <- apply(v$data[, 2:limit],2,as.numeric)
.negative <- any(colms < 0, na.rm = TRUE)
if (.negative) {
return(
list(off = TRUE,
error = err$hfdata(
error = paste("wrongdatavalues_", addon, sep=""))
)
)
}
} else {
if (!is.data.frame(v$data) & !is.matrix(v$data)) {
return(
list(off = TRUE,
error = err$tdata(
error = "wrongclass",
class = class(v$data)
)
)
)
}
limit <- 2
if (ncol(v$data) < 2) {
return(
list(off = TRUE,
error = err$hfdata(
error = "fewvariables",
cols = ncol(v$data),
limit = limit)
)
)
}
.types <- vapply(2:limit, function(x) is.numeric(v$data[, x]), logical(1))
dtypes <- vapply(2:limit, function(x) typeof(v$data[, x]), character(1))
if (!all(.types)) {
return(
list(off = TRUE,
error = err$tdata(
error = "wrongdatatypes",
dtypes = dtypes)
)
)
}
.negative <- any(v$data[, 1:limit] < 0, na.rm = TRUE)
if (.negative) {
return(
list(off = TRUE,
error = err$tdata(
error = "wrongdatavalues")
)
)
}
}
# If the argument 'data' is valid, then add its row number to the default
# range of layers and xtraclusters using the option "numberoftradingdays"
options("numberoftradingdays" = nrow(v$data))
return(list(off = FALSE, error = ""))
},
parameters = function(vargs) {
v <- vargs$al
err <- vargs$errors
varname <- vargs$name
xparams <- v[[varname]]
if (is.null(xparams))
return(list(off = FALSE, error = ""))
.types <- suppressWarnings(!is.na(as.numeric(xparams)))
allnumeric <- prod(.types)
if (v$fn %in% c("adjpindata", "adjpin")) {
if (allnumeric == 0)
return(list(off = TRUE,
error = err$adjpindata(
error = "wrongtype",
ntype = which(.types == FALSE),
ktype = typeof(xparams[which(.types == FALSE)[1]])
)
))
xparams <- as.numeric(xparams)
if (length(xparams) != 10)
return(list(off = TRUE,
error = err$adjpindata(
error = "wrongdim",
size = length(xparams)
)
))
invalidalpha <- ((xparams[1] <= 0) | (xparams[1] >= 1))
if (invalidalpha)
return(list(off = TRUE,
error = err$adjpindata(
error = "wrongalpha",
alpha = xparams[1]
)
))
invalidprobs <- (any(xparams[1:4] < 0) | any(xparams[1:4] > 1))
if (invalidprobs)
return(list(off = TRUE,
error = err$adjpindata(
error = "wrongprobabilities",
size = length(xparams)
)
))
invalidrates <- (
any(xparams[5:10] < 0))
if (invalidrates) {
return(list(off = TRUE,
error = err$adjpindata(
error = "wrongrates",
size = length(xparams)
)
))
}
return(list(off = FALSE, error = ""))
} else {
if (allnumeric == 0)
return(list(off = TRUE,
error = err$mpindata(
error = "wrongtype",
ntype = which(.types == FALSE),
ktype = typeof(xparams[which(.types == FALSE)[1]])
)
))
xparams <- as.numeric(xparams)
# If the argument 'layers' is provided, check compatibility, otherwise
# check that it has the size 3J + 2
xlayers <- (length(xparams) - 2) / 3
validsize <- (ux$is.integer(xlayers))
if (!validsize)
return(list(off = TRUE, error = err$mpindata(
error = "wrongdim", size = length(xparams))))
if (v$fn == "mpin" && !is.null(v$layers) && xlayers != v$layers) {
ux$show(m = uierrors$layers(code = 1, NULL), warning = TRUE)
}
invalidalpha <- (
any(xparams[1:xlayers] <= 0) | any(xparams[1:xlayers] >= 1))
if (invalidalpha)
return(list(
off = TRUE,
error = err$mpindata(error = "wrongalpha", layers = xlayers)))
invalidprobs <- (any(xparams[1:(2 * xlayers)] < 0) |
any(xparams[1:(2 * xlayers)] > 1))
if (invalidprobs)
return(list(
off = TRUE,
error = err$mpindata(error = "wrongprobabilities",
size = length(xparams),
layers = xlayers))
)
raterange <- (2 * xlayers + 1):(3 * xlayers + 2)
invalidrates <- (
any(xparams[raterange] <= 0))
if (invalidrates) return(list(off = TRUE, error = err$mpindata(
error = "wrongrates", size = length(xparams), layers = xlayers)))
mu <- xparams[(2 * xlayers + 1):(3 * xlayers)]
if (any(diff(mu) <= 0)) return(list(off = TRUE, error = err$mpindata(
error = "rankedmu", size = length(xparams), layers = xlayers)))
return(list(off = FALSE, error = ""))
}
},
restricted = function(vargs) {
v <- vargs$al
err <- vargs$errors
if (is.list(v$restricted) && (length(v$restricted) == 0))
return(list(off = FALSE, error = ""))
if (is.null(v$restricted) || !is(v$restricted, "list"))
return(list(off = TRUE,
error = err$list("restricted", class(v$restricted))))
rkeys <- names(v$restricted)
keys <- c("mu", "eps", "d", "theta")
unknown <- setdiff(rkeys, keys)
if (length(unknown) > 0)
return(list(off = TRUE, error = err$restricted(
error = "unrecognized",
unknown = unknown
)))
binary <- vapply(v$restricted, is.logical, logical(1))
allbinary <- prod(binary)
if (!allbinary) {
nonbinary <- rkeys[which(binary == FALSE)[[1]]]
return(list(off = TRUE, error = err$restricted(
error = "nonbinary",
nonbinary = nonbinary
)))
}
return(list(off = FALSE, error = ""))
},
xlogical = function(vargs) {
x <- vargs$var
varname <- vargs$name
err <- vargs$errors
if (is.null(x) || !is.logical(x))
return(list(off = TRUE, error = err$logical(varname, typeof(x))))
return(list(off = FALSE, error = ""))
},
xcharacter = function(vargs) {
x <- vargs$var
varname <- vargs$name
range <- vargs$range
err <- vargs$errors
if (is.null(x) || !is.character(x)) {
return(list(off = TRUE,
error = err$character(name = varname, xrange = range,
type = typeof(x))))
}
x <- toupper(x)
if (!all(x %in% range))
return(list(
off = TRUE,
error = err$character(
name = varname, val = x, xrange = range, type = NULL)))
return(list(off = FALSE, error = ""))
},
xinteger = function(vargs) {
x <- vargs$var
varname <- vargs$name
bounds <- vargs$range
err <- vargs$errors
if (varname == "layers") {
if (is.null(x))
return(list(off = FALSE, error = ""))
}
if (!ux$is.integer(x)) {
return(list(off = TRUE,
error = err$integer(name = varname, bounds = bounds,
type = typeof(x))))
}
xmin <- bounds[1]
xmax <- bounds[2]
if (x < xmin || x > xmax)
return(list(
off = TRUE,
error = err$integer(
name = varname, val = x, bounds = bounds, type = NULL)))
return(list(off = FALSE, error = ""))
},
xnumeric = function(vargs) {
x <- vargs$var
varname <- vargs$name
bounds <- vargs$range
strict <- vargs$strict
err <- vargs$errors
if (!ux$is.numeric(x)) {
return(
list(off = TRUE,
error = err$numeric(x = varname, bounds = bounds,
type = typeof(x), strict = strict)))
}
xmin <- bounds[1]
xmax <- bounds[2]
cond <- ifelse(strict, x <= xmin || x >= xmax, x < xmin || x > xmax)
if (cond)
return(list(
off = TRUE,
error = err$numeric(
x = varname, bounds = bounds, type = NULL, strict = strict)))
return(list(off = FALSE, error = ""))
},
xlist = function(vargs) {
x <- vargs$var
varname <- vargs$name
err <- vargs$errors
if (is.null(x) || !is(x, "list"))
return(list(off = TRUE, error = err$list(varname, class(x))))
return(list(off = FALSE, error = ""))
},
burnin = function(vargs) {
err <- uierrors$arguments()
# check that the value of burnin is smaller than 'sweeps'
valid <- (vargs$al$burnin < vargs$al$sweeps)
if (!valid)
return(list(off = TRUE, error = err$bayescompatibility(
sweeps = vargs$al$sweeps, burnin = vargs$al$burnin)))
return(list(off = FALSE, feedback = ""))
}
)
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.