Nothing
## FILE HEADER
##
## Script name:
## utilities_messages.R
##
## Purpose of script:
## lists and computes all messages displayed in the package,
## including error messages, and warnings. It contains four
## list of functions:
## :: + uix:
## ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
## computes messages that are displayed when a given function
## is being executed. It gives an idea about the operation
## performed.
## :: + uierrors:
## ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
## computes errors that are displayed when an error occurs,
## and the execution is stopped.
## :: + uiconflicts
## ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
## computes conflict messages that are displayed when there
## are conflicts between different controls for the function
## generating datasets: generatedata_mpin()
## :: + uiclasses
## ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
## computes messages and outputs displayed when a given S4
## object is displayed. The S4 objects are either estimation
## result output with names "estimate.*", where * refers to
## the name of the model being estimated; and objects storing
## simulation data results, namely objects of class 'dataset'
## and of class 'data.series'. For more information, check the
## file 'output_classes.R'.
##
##
## 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 | |
## +++++++++++++++++++++++++
uix <- list(
classification = function(rows = 0, method = "", timelag = 0,
time = "", isparallel = T) {
ui <- list()
ui$start <- "[+] Trade classification started"
ui$complete <- "[+] Trade classification completed"
ui$unrecognized <- paste(" |[=] Unknown classification algorithm:",
"Tick algorithm is used")
ui$algorithm <- paste(
" |[=] Classification algorithm \t:", method, "algorithm")
ui$number <- paste(
" |[=] Number of trades in dataset\t:", ux$sep(rows), "trades")
ui$lag <- paste(
" |[=] Time lag of lagged variables \t:", timelag, "milliseconds")
process <- ifelse(isparallel, "parallel", "sequential")
ui$computing <- paste(
" |[1] Computing lagged variables \t: using", process, "processing")
ui$progressbar <- " of variables computed"
ui$time <- paste(" |[=] Intraday trades classified \t: in", time)
ui$aggregating <- ifelse(
method == "Tick",
paste(" |[1] Computing aggregated trades \t: using Tick algorithm"),
paste(" |[2] Computing aggregated trades \t: using lagged variables")
)
return(ui)
},
mpin = function(nrows = 0, layers = 0, initlayers = 0, exptime = 0,
maxinit = 0, maxlayers = 0, criterion = "") {
ui <- list()
ui$start <- "[+] MPIN estimation started"
ui$complete <- "\n[+] MPIN estimation completed"
ui$emcomplete <- "[+] MPIN estimation completed"
ui$detectsets <- paste(
" |[1] Detecting layers from initialsets: ",
initlayers, " information layer(s) detected", sep = "")
ui$detectdata <- " |[1] Detecting layers from data \t:"
ui$algorithm <- list(ECM = " using the ECM algorithm",
E = " using Ersan (2016)",
EG = " using Ersan and Ghachem (2022a)")
ui$loadinitials <- paste(
"\r |[2] Loading initial parameter sets\t: ", nrows,
" custom initial set(s) loaded", sep = "")
ui$numlayers <- paste(" |[=] Number of layers in the data \t: ", layers,
" information layer(s) detected", sep = "")
ui$selectedlayers <- paste(" |[1] Using user-selected layers \t: ", layers,
" layer(s) assumed in the data", sep = "")
ui$computinginitials <- paste(
" |[2] Computing initial parameter sets :",
"using algorithm of Ersan (2016)")
ui$expectedtime <- paste(
" |[3] Computing expected running time \t: ", exptime, sep = "")
ui$mlemethod <- paste(
" |[3] Estimating the MPIN model \t:",
" Maximum-likelihood standard estimation", sep = "")
ui$emmethod <- paste(" |[3] Estimating the MPIN model \t:",
" Expectation-Conditional Maximization algorithm", sep = "")
ui$differentlayers <- paste(
" |[!] The number of layers detected (", initlayers,
") differs from the argument",
"'layers' (", layers, ")", sep = "")
ui$progressbar <- " of mpin estimation completed"
ui$emprogressbar <- paste(
" of estimation completed [", layers, " layer(s)]", sep = "")
ui$layersrange <- paste(" |[1] Computing the range of layers \t: ",
layers, " layer(s) provided by user", sep = "")
ui$maxlayersrange <- paste(" |[1] Computing the range of layers \t: ",
"information layers from 1 to ", maxlayers, sep = "")
ui$selectinitials <- paste(" |[=] Selecting initial parameter sets : max",
maxinit, "initial sets per estimation")
ui$selectcriterion <- paste("\n |[3] Selecting the optimal model \t:",
" using lowest Information Criterion (", criterion, ")", sep = "")
return(ui)
},
adjpin = function(nrows = 0, exptime = 0, maxinit = 0, init = "",
maxlayers = 0, criterion = "") {
ui <- list()
if (init == "RANDOM") init <- "random"
ui$start <- "[+] AdjPIN estimation started"
ui$complete <- "\n[+] AdjPIN estimation completed"
ui$equalthetas <- paste(
"Unable to estimate the AdjPIN model with equal thetas using the",
"ECM algorithm.\nThe AdjPIN model", "will be estimated with the ",
"standard maximum likelihood estimation.\n-----------")
ui$unknowntype <- paste(
" |[=] Unrecognized argument 'initialsets', it is set to 'GE'.")
ui$loadinitials <- paste(
"\r |[2] Loading initial parameter sets\t: ", nrows,
" custom initial set(s) loaded", sep = "")
ui$computinginitials <- paste(
"\r |[1] Computing initial parameter sets\t:", nrows,
init, "initial sets generated")
ui$mlemethod <- paste(
" |[2] Estimating the AdjPIN model \t:",
" Maximum-likelihood Standard Estimation", sep = "")
ui$emmethod <- paste(
" |[2] Estimating the AdjPIN model \t:",
" Expectation-Conditional Maximization algorithm", sep = "")
ui$progressbar <- " of AdjPIN estimation completed"
return(ui)
},
pin = function(nrows = 0, type = "") {
ui <- list()
ui$start <- "[+] PIN Estimation started "
ui$loadinitials <- paste(" |[2] Loading initial parameter sets\t: ",
nrows, " ", type, " initial set(s) loaded", sep = "")
ui$mlemethod <- paste(" |[3] Estimating PIN model (1996) \t:",
"Using Maximum Likelihood Estimation")
ui$bayesmethod <- paste(" |[3] Estimating PIN model (1996) \t:",
"Using Bayesian Gibbs Sampling")
ui$complete <- "\n[+] PIN Estimation completed"
ui$progressbar <- " of PIN estimation completed"
title <- " |[1] Likelihood function factorization:"
ui$factorization <- list(
EHO = paste(title, "Easley, Hvidkjaer and O'Hara (2010)"),
LK = paste(title, "Lin and Ke (2011)"),
E = paste(title, "Ersan (2016)"),
NONE = paste(title, "No factorization")
)
return(ui)
},
adjpindata = function(ndata = 0) {
ui <- list()
ui$start <- "[+] Adjpin data generation started"
ui$complete <- "\n[+] Adjpin data generation completed"
ui$nsimulation <- paste(" |[=] Generating", ux$sep(ndata),
"AdjPIN datasets")
return(ui)
},
mpindata = function(ndata = 0) {
ui <- list()
ui$start <- "[+] MPIN data generation started"
ui$complete <- "\n[+] MPIN data generation completed"
ui$nsimulation <- paste(" |[=] Generating", ux$sep(ndata),
"MPIN datasets")
return(ui)
},
vpin = function(timebarsize = 0) {
ui <- list()
ui$start <- "[+] VPIN Estimation started."
ui$step1 <- " |-[1] Checking and preparing the data..."
ui$step2 <- paste(
" |-[2] Creating ", timebarsize, "-second timebars...", sep = "")
ui$step3 <- " |-[3] Calculating Volume Bucket Size (VBS) and Sigma(DP)..."
ui$step4 <- paste(" |-[4] Breaking up large ", timebarsize,
"-second timebars' volume...", sep = "")
ui$step5 <- paste(
" |-[5] Assigning ", timebarsize, "-second timebars into ",
"buckets...", sep = "")
ui$step6 <- paste(" |-[6] Balancing timebars and adjusting bucket sizes",
"to VBS...")
ui$step7 <- " |-[7] Calculating aggregate bucket data..."
ui$step8 <- " |-[8] Calculating VPIN vector..."
ui$complete <- "[+] VPIN estimation completed"
ui$aborted <- "[+] VPIN estimation aborted!"
return(ui)
}
)
uierrors <- list(
mpin = function(cols = 0) {
er <- list()
er$wrongtype <- "The argument 'initialsets' should be a dataframe!"
er$fn <- "MPIN estimation aborted!"
er$failed <- paste(
"\r[ERROR]\n\rThe MPIN maximum likelihood optimization failed!",
"\nImpossible to evaluate the log-likelihood function at the initial\n",
"\rparameter sets provided! Please review your initial parameter sets\n",
"\rand try again!", sep = "")
er$emfailed <- paste(
"The estimation using the Expectation-Conditional Maximization",
" algorithm failed!",
"\nThe ECM algorithm has failed to converge at the provided initial\n",
"\rparameter sets! Please review your initial parameter sets\n",
"\rand try again!", sep = "")
er$wronglength <- paste(
"\r[x] 'initialsets' must have a length 3J+2, for some integer",
" J (number of layers):\n\r[-> You have supplied a dataframe ",
"with ", cols, "variables.")
return(er)
},
pin = function(grid_size, dr = 0) {
er <- list()
er$failed <- paste(
"\r[ERROR]\n\rThe PIN maximum likelihood optimization failed!",
"\nImpossible to evaluate the log-likelihood function at the initial\n",
"\rparameter sets provided! Please review your initial parameter sets\n",
"\ror choose another factorization", sep = "")
er$fn <- "PIN estimation aborted!"
er$yzdeleted <- paste(
dr, "initial sets have been deleted as they contained negative",
"values for eps.s!")
er$eacorrected <- paste(
dr, "initial sets have been deleted by the correction of",
"Ersan and Alici (2016)!")
er$displaysets <- function(fn, nrows)
return(paste(
"The function ", fn, " has generated ", nrows, " initial parameter",
" sets.\n\rTo display them, either store them in a variable ",
"or call", " (", fn, "). \n\rTo hide these messages, set the argument",
" 'verbose' to FALSE.", sep = ""))
return(er)
},
adjpin = function() {
er <- list()
er$failed <- paste(
"\r[ERROR]\n\rThe AdjPIN estimation failed!",
"\nImpossible to evaluate the log-likelihood function at the initial\n",
"\rparameter sets provided! Please review your initial parameter sets.",
sep = "")
er$unknownmethod <- paste(
"\rThe argument \'method\' takes one of two values \"ECM\" or \"ML\".")
er$wrongtype <- paste(
"\rThe argument 'initialsets' must be a character string or a dataframe.")
er$wrongsize <- paste(
"\rThe number of variables in the dataframe 'initialsets' is not \n",
"\rcompatible with the argument 'restricted'", sep = "")
er$wrongvalues <- paste(
"\rIn the dataframe 'initialsets', some probabilities are",
"outside [0,1] or some parameters are negative.")
er$wrongalgorithm <- paste(
"\rThe argument 'initialsets' should be a dataframe or take on value from",
"\n\rthe list 'GE', 'CL', and 'RANDOM'")
er$wrongnuminit <- paste(
"\rThe argument 'num_init' should be a positive integer."
)
er$wrongfact <- paste(
"\rThe argument is a binary argument, and takes either 'TRUE' or 'FALSE!'"
)
er$wrongxtraclusters <- paste(
"\rThe argument 'xtraclusters' is a non-negative integer that ",
"can't exceed \n\rthe number of observations in the dataset!"
)
er$wrongrestriction <- paste(
"The argument 'restricted' should be of type list, composed of",
" up to four\n\rbinary values with the following names: 'theta',",
" 'mu', 'eps', and 'd'!")
er$fn <- "AdjPIN estimation aborted!"
return(er)
},
adjpindata = function() {
er <- list()
er$unknown <- "An error occured during the AdjPIN data generation"
er$notadataframe <- "The argument 'initialsets' should be a dataframe!"
er$wrongdim <- paste(
"Wrong dimension of the argument 'parameters'.",
"It should contain 10 parameters!", sep = "")
er$wrongvalues <- paste(
"\rError: In the argument 'initialsets', either some probabilities ",
"are outside [0,1]\n\ror some parameters are negative.")
er$fn <- "AdjPIN data simulation aborted!"
er$failed <- paste(
"\r[ERROR]\n\rThe MPIN maximum likelihood optimization failed!",
"\nImpossible to evaluate the log-likelihood function at the initial\n",
"\rparameter sets provided! Please review your initial parameter sets\n",
"\rand try again!", sep = "")
er$emfailed <- paste(
"The estimation using the Expectation-Conditional Maximization",
"algorithm failed!",
"\nThe ECM algorithm has failed to converge at the provided initial\n",
"\rparameter sets! Please review your initial parameter sets\n",
"\rand try again!", sep = "")
return(er)
},
mpindata = function() {
er <- list()
er$unknown <- "An error occured during the MPIN data generation"
er$notadataframe <- "The argument 'initialsets' should be a dataframe!"
er$wrongdim <- paste(
"Wrong dimension of the argument 'parameters'.",
"It should contain 10 parameters!", sep = "")
er$esrange <- "A range for eps.s should be provided when eps_ratio = 0!"
er$epsimpossible <- paste(
"[x] Impossible to generate eps.b and eps.s given the",
" provided ranges and eps_ratio!\n\r Review the ranges",
" or deactivate the eps_ratio by setting it to 0.")
er$fn <- "MPIN data simulation aborted!"
er$failed <- paste(
"\r[ERROR]\n\rThe MPIN maximum likelihood optimization failed!",
"\nImpossible to evaluate the log-likelihood function at the initial\n",
"\rparameter sets provided! Please review your initial parameter sets\n",
"\rand try again!", sep = "")
er$emfailed <- paste(
"The estimation using the Expectation-Conditional Maximization",
"algorithm failed!",
"\nThe ECM algorithm has failed to converge at the provided initial\n",
"\rparameter sets! Please review your initial parameter sets\n",
"\rand try again!", sep = "")
return(er)
},
summary = function() {
ui <- list()
ui$invalid <- paste("getSummary() is only valid for S4 objects",
"of type 'estimate.mpin.ecm'")
return(ui)
},
vpin = function() {
er <- list()
er$failed <- paste(
"Error: The sample length is larger than the number of buckets in the ",
"data!\n[=] Please choose a higher number of buckets per day 'buckets'",
" or a smaller\n sample length 'samplength' or both.", sep = ""
)
er$largetimbarsize <- paste("Error: the argument 'timebarsize' shall not",
"exceed the total duration in the dataset!")
er$missingdata <- paste(
"The argument 'data' is missing!, A dataset is needed",
"to estimate VPIN!")
er$wrongdata <- paste("The argument 'data' should be of class 'data.frame'",
" containing at least 3 variables!")
er$wrongargs <- paste(
"\rError: The arguments 'timebarSize', 'buckets', and ",
"'samplength' should be integers!", sep = "")
er$fn <- "VPIN estimation aborted!"
return(er)
},
ranges = function(var = "", code, val = 0) {
# error codes:
# 1 : Non numeric range
# 2 : probability range is not valid
# 3 : rate range is not valid
# 4 : Duplicated keys in list 'ranges'
# 5 : Unrecognized keys in list 'ranges'
qvariable <- unname(vapply(
var, sQuote, FUN.VALUE = character(length(var))))
var <- paste(var, collapse = ", ")
interval <- ifelse(var == "alpha", "(0,1)", "[0,1]")
qvariable <- paste(qvariable, collapse = ", ")
if (length(val) > 1 && val[1] == val[2]) val <- val[1]
if (length(val) > 1)
val <- paste("(", paste(val, collapse = ", "), ")", sep = "")
if (is.character(val)) val <- shQuote(val)
errors <- list(
paste("\r[x] ", qvariable, " must be of type 'numeric':\n\r[-> ",
"You have supplied the following value for ", qvariable, ": ",
val, ".", sep = ""),
paste("\r[x] ", qvariable, " must be either a real number from ",
"or a subset of the interval ", interval, ":\n\r[-> ",
"You have supplied the following value for ", qvariable, ": ",
val, ".", sep = ""),
paste("\r[x] '", qvariable, " must be either a real number from ",
"or a valid subset of the positive reals", ":\n\r[-> ",
"You have supplied a range for '", qvariable,
"' that is not a valid subset of the positive reals.", sep = ""),
paste("\r[x] Duplicated elements in the list 'ranges':\n\r[-> ",
"You have supplied duplicate ranges for the variable(s): ",
qvariable, ".", sep = ""),
paste("\r[x] Unrecognized elements in the list 'ranges':\n\r[-> ",
"You have supplied ranges for unrecognized variable(s): ",
qvariable, ".", sep = ""),
paste("\rError: 'theta' and 'thetap' cannot be simultaneously ",
"equal to 1:\n\r[-> You have supplied the same value (=1) for ",
"both 'theta', and 'thetap'.", sep = "")
)
return(errors[[code]])
},
controls = function(var, val = 0, code, keys) {
bounds <- .default$controlbounds()
minv <- bounds$minv
maxv <- bounds$maxv
if (is.character(val)) val <- shQuote(val)
val <- paste(val, collapse = ",")
if (length(val) > 1) val <- paste("(", val, ")", sep = "")
varname <- paste(unname(
vapply(keys[var], sQuote, FUN.VALUE = character(length(var)))),
collapse = ", ")
errors <- list(
paste("\r[x] Unrecognized elements in the argument '...':\n\r[-> ",
"You have supplied value for unrecognized variable(s): ",
unname(vapply(var, sQuote, FUN.VALUE = character(1))), ".",
sep = ""),
paste("\r[x] ", varname, " must be of type 'numeric':\n\r[-> ",
"You have supplied the following value for ", varname, ": ",
val, ".", sep = ""),
paste("\r[x] ", varname, " must be an integer from the set {", minv[var],
",...,", maxv[var], "}:\n\r[-> ", "You have supplied the following",
" value for ", varname, ": ", val, ".", sep = ""),
paste("\r[x] ", varname, " must lie in the interval (", minv[var],
",", maxv[var], "):\n\r[-> ", "You have supplied the following",
" value for ", varname, ": ", val, ".", sep = ""),
paste("\r[x] ", varname, " must be either 0 or selected from (",
minv[var], ",", maxv[var], "):\n\r[-> ", "You have supplied",
" the following non-zero value for ", varname, ": ", val,
".", sep = ""),
paste("\r[x] The elements of the range for ", varname, " ",
"must be increasingly ranked:\n\r[-> ",
"You have supplied a range for ", varname,
" that is not valid.", sep = ""),
paste("\r[x] Duplicated elements in the argument '...':\n\r[-> ",
"You have supplied duplicate values for the variable(s): ",
varname, ".", sep = "")
)
return(errors[[code]])
},
hyperparams = function(error, varname, val = 0, adj = FALSE) {
bounds <- .default$hyperbounds(adj)
minv <- bounds$minv
maxv <- bounds$maxv
keys <- names(.default$hyperparams(adj))
var <- which(keys == varname)
xset <- paste("{\"", paste(.default$criterion, collapse = "\", \"",
sep = ""), "\"", sep = "")
varname <- Map(sQuote, varname)
if (length(varname) > 1) varname <- paste(varname, collapse = ", ")
if (is.character(val)) val <- shQuote(val)
xmessage <- switch(
error,
"unrecognized" = paste(
"\r[x] Unrecognized elements in the argument 'hyperparams':\n\r[-> ",
"You have supplied value for unrecognized variable(s): ",
varname, ".", sep = ""),
"duplicate" = paste(
"\r[x] Duplicated elements in the argument 'hyperparams':\n\r[-> ",
"You have supplied duplicate values for the variable(s): ",
varname, ".", sep = ""),
"notnumeric" = paste(
"\r[x] ", varname, " must be of type 'numeric':\n\r[-> ",
"You have supplied a value of class ", val, " for ", varname, ".",
sep = ""
),
"notcharacter" = paste(
"\r[x] ", varname, " must be of type 'character':\n\r[-> ",
"You have supplied a value of class ", val, " for ", varname, ".",
sep = ""
),
"intrange" = paste(
"\r[x] ", varname, " must be an integer from the set {", minv[var],
",...,", maxv[var], "}:\n\r[-> ", "You have supplied the following",
" value for ", varname, ": ", val, ".", sep = ""
),
"interval" = paste(
"\r[x] ", varname, " must lie in the interval [", minv[var],
", ", maxv[var], "]:\n\r[-> ", "You have supplied the following",
" value for ", varname, ": ", val, ".", sep = ""
),
"charrange" = paste(
"\r[x] ", varname, " must be of type character from the set ", xset,
"}:\n\r[-> ", "You have supplied the following",
" value for ", varname, ": ", val, ".", sep = ""
),
)
return(xmessage)
},
layers = function(code, args = NULL) {
response <- switch(
EXPR = code,
paste(
"\r[Warning]\nThe number of layers derived from 'parameters' is not",
" compatible with 'layers'.\nThe argument 'layers' will be ignored",
sep = ""),
paste("\r[x] Impossible to generate ", args$layers, " layers:\n\r[-> ",
"The value of 'layers' exceeds the number of days/observations (",
args$days, ")!", sep = ""),
paste(
"\r[x] Impossible to generate ", args$layers, " layers:\n\r[-> ",
"You have supplied a minimum value of alpha that is too high (",
args$minalpha, ")!", sep = ""),
paste("\r[Warning] The maximum layers possible given that ",
"alpha >= ", args$minalpha, " is: ", floor(1 / args$minalpha),
".\n", sep = "")
)
return(response)
},
detection = function() {
ui <- list()
ui$fn <- "MPIN layer detection aborted!"
return(ui)
},
fact = function(model = NULL) {
ui <- list()
ui$fn <- paste("Computation of", model, "factorization aborted!")
return(ui)
},
aggregation = function() {
ui <- list()
ui$fn <- "High-frequency data aggregation aborted!"
return(ui)
},
arguments = function() {
er <- list()
er$initials <- function(error, class = NULL, cols = 0, rvars = 0,
length=0, unknown = "") {
xmessage <- switch(
error,
"wrongclass" = paste(
"\r[x] 'initialsets' must be a character string or a dataframe:",
"\n\r[-> You have supplied an argument of class '", class, "'.",
sep = ""),
"wrongsize" = paste(
"\r[x] The size of 'initialsets' must be compatible with ",
"'restricted':\n\r[-> 'initialsets' has ", cols, " variables,",
" while a restricted model has ", rvars, " variables",
sep = ""),
"wrongvalues" = paste(
"\r[x] 'initialsets' must contain only valid values:\n\r[-> ",
"some probabilities are outside [0,1] or some trading rates ",
"are negative.", sep = ""),
"wrongalgorithm" = paste(
"\r[x] 'initialsets' must be a dataframe or a value from ",
"{\"GE\", \"CL\", and \"RANDOM\"}:\n\r[-> 'initialsets' takes the ",
"unrecognized value \"", unknown, "\".", sep = ""),
"wronglength" = paste(
"\r[x] 'initialsets' must have a length 3J+2, for some integer",
" J (number of layers):\n\r[-> You have supplied a dataframe ",
"with ", cols, "variables."),
"wrongtype" = paste(
"\r[x] 'initialsets' must be a dataframe:\n\r[-> ",
"You have supplied an argument of class '", class, "'.",
sep = "")
)
}
er$logical <- function(x, type = NULL) {
return(paste(
"\r[x] '", x,
"' must be of type 'logical' from the set {TRUE, FALSE}:",
"\n\r[-> You have supplied an argument of type '", type, "'.",
sep = "")
)
}
er$list <- function(x, type = NULL) {
return(paste(
"\r[x] '", x, "' must be of type 'list':\n\r[-> ",
"You have supplied an argument of type '", type, "'.",
sep = "")
)
}
er$character <- function(name, val = 0, xrange, type = NULL) {
xset <- paste(
"{", paste(shQuote(xrange), collapse = ", "), "}", sep = "")
return(paste(
"\r[x] '", name, "' must be of type 'character' from the set ",
xset, ":\n\r[-> ",
ifelse(
!is.null(type),
paste("You have supplied an argument of type '",
type, "'.", sep = ""),
paste("You have supplied the following character string: \"",
val, "\".", sep = "")),
sep = "")
)
}
er$integer <- function(name, val = 0, bounds, type = NULL) {
xset <- paste("{", bounds[1], ", ..., ", bounds[2], "}", sep = "")
xmessage <- paste(
"\r[x] '", name, "' must be an integer from the set ",
xset, ":\n\r[-> ",
ifelse(
!is.null(type),
paste("You have supplied an argument of type '",
type, "'.", sep = ""),
paste("You have supplied the following integer: ",
val, ".", sep = "")),
sep = "")
return(xmessage)
}
er$numeric <- function(x, bounds, type = NULL, strict = TRUE) {
xset <- paste("(", bounds[1], ", ", bounds[2], ")", sep = "")
if (!strict) xset <- paste("[", bounds[1], ", ", bounds[2], ")", sep = "")
xmessage <- paste(
"\r[x] '", x, "' must be numeric from the set ", xset, ":\n\r[-> ",
ifelse(
!is.null(type),
paste("You have supplied an argument of type '",
type, "'.", sep = ""),
paste("You have supplied a numeric variable not in ",
xset, ".", sep = "")),
sep = "")
return(xmessage)
}
er$hfdata <- function(error, class = NULL, cols = 0, type1 = NULL,
limit = 0, failure = 0, dtypes = NULL,
negative = 0) {
dtypes <- paste(
"{", paste(shQuote(dtypes), collapse = ", "), "}", sep = "")
xmessage <- switch(
error,
"wrongclass" = paste(
"\r[x] 'data' must be of class 'dataframe', or 'matrix':\n\r[-> ",
"You have supplied an argument of class '", class, "'.",
sep = ""),
"fewvariables" = paste(
"\r[x] 'data' must contain at least ", limit, " columns:\n\r[-> ",
"You have supplied a dataframe with ", cols, " columns.",
sep = ""),
"nottimestamp" = paste(
"\r[x] The fist column of 'data' must be of type 'character' or ",
"'POSIXct':\n\r[-> You have supplied a first column of type '",
type1, "'.", sep = ""),
"notdate" = paste(
"\r[x] The first column of 'data' must be convertible into a date:",
"\n\r[-> The row number ", failure, " of the first column cannot be",
" converted into a 'date' object.", sep = ""),
"wrongdatatypes_vpin" = paste(
"\r[x] The second, and third columns of 'data' must be ",
"numeric:\n\r[-> You have supplied columns with types ", dtypes,
".", sep = ""),
"wrongdatatypes_agg" = paste(
"\r[x] The second, third, and fourth columns of 'data' must be ",
"numeric:\n\r[-> You have supplied columns with types ", dtypes,
".", sep = ""),
"wrongdatavalues_vpin" = paste(
"\r[x] The second, and third columns of 'data' must be ",
"positive:\n\r[-> Some values of the second, or third ",
"columns are non-positive.", sep = ""),
"wrongdatavalues_agg" = paste(
"\r[x] The second, third, and fourth columns of 'data' must be ",
"positive:\n\r[-> Some values of the second, third, or fourth ",
"columns are non positive.", sep = "")
)
}
er$adjpindata <- function(error, ntype = 0, ktype = 0,
size = 0, alpha = 0) {
xmessage <- switch(
error,
"wrongtype" = paste(
"\r[x] 'parameters' must be of type 'numeric':\n\r[-> ",
"The value of 'parameters' at positition ", ntype,
" is of type '", ktype, "'.", sep = ""),
"wrongdim" = paste(
"\r[x] 'parameters' must contain 10 values:\n\r[-> ",
"You have supplied a numeric vector of size ", size, ".",
sep = ""),
"wrongalpha" = paste(
"\r[x] The first value of 'parameters' (alpha) is a probability and ",
"must belong to (0,1):\n\r[-> The first value of the provided ",
"'parameters' (", alpha, ") is ", ifelse(
alpha <= 0, "non-positive (<= 0)!", "larger than or equal to 1!"),
sep = ""),
"wrongprobabilities" = paste(
"\r[x] The first four values of 'parameters' (probabilities) must ",
"belong to [0,1]:\n\r[-> Some probabilities in 'parameters' are either",
" negative or larger than 1!", sep = ""),
"wrongrates" = paste(
"\r[x] The last six values of 'parameters' (trading rates) must be",
" positive:\n\r[-> Some trading rates in 'parameters' are ",
"negative or zero!", sep = ""),
)
}
er$mpindata <- function(error, layers = 0, size = 0) {
xlayers <- ifelse(layers == 1, " ", paste("", layers, "", sep = " "))
xmessage <- switch(
error,
"wrongtype" = paste(
"\r[x] 'parameters' must be of type 'numeric':\n\r[-> ",
"The value of 'parameters' at positition ", ntype, " is of type '",
ktype, "'.", sep = ""),
"wrongdim" = paste(
"\r[x] 'parameters' must have a length of 3J+2, for some J ",
"(number of layers):\n\r[-> You have supplied a numeric vector of",
" size ", size, ".", sep = ""),
"incompatibledim" = paste(
"\r[x] 'parameters' must have a length of 3J+2, where J is the ",
"number of layers:\n\r[-> You have supplied an argument 'layers' - ",
layers, " -, and the size of 'parameters' is ", size, ". \n\r[-> ",
"Remove one of the two arguments ('parameters' or 'layers'), and try",
" again!", sep = ""),
"wrongalpha" = paste(
"\r[x] The first", xlayers,
"value(s) of 'parameters' (alpha) must belong to (0,1):\n\r[-> The first",
xlayers, "value(s) of the provided 'parameters' lie outside (0,1)!",
sep = ""),
"wrongprobabilities" = paste(
"\r[x] The first ", ifelse(layers == 1, "two", 2 * layers),
" value(s) of 'parameters' (probabilities) must belong to [0,1]:\n\r[->",
" Some probabilities in 'parameters' are either negative or larger than",
" 1!", sep = ""),
"wrongrates" = paste(
"\r[x] The last ", layers + 2, " values of 'parameters' (trading rates)",
" must be positive:\n\r[-> Some trading rates in 'parameters' ",
"are negative or zero!", sep = ""),
"rankedmu" <- paste(
"\r[x] The values of 'parameters' in positions ", 2 * layers + 2, ":",
3 * layers,
" (informed trading rates muj) must be increasingly ranked:\n\r[-> ",
"The informed trading rates in 'parameters' (muj) are not increasingly ",
"ranked!", sep = "")
)
}
er$restricted <- function(error, unknown = NULL, nonbinary = NULL) {
qvariable <- unname(vapply(unknown, sQuote, FUN.VALUE = character(1)))
qvariable <- paste(qvariable, collapse = ", ")
xmessage <- switch(
error,
"unrecognized" = paste(
"\r[x] Unrecognized elements in the list 'restricted':\n\r[-> ",
"You have supplied values for unrecognized variable(s): ",
qvariable, ".", sep = ""),
"nonbinary" = paste(
"\r[x] All variables in 'restricted' must take logical values:",
"\n\r[-> You have supplied a non logical value for the variable '",
nonbinary, "'.", sep = "")
)
}
er$tdata <- function(error, class = NULL, cols = 0,
dtypes = NULL, limit = 0) {
dtypes <- paste("{",
paste(shQuote(dtypes), collapse = ", "),
"}", sep = "")
xmessage <- switch(
error,
"wrongclass" = paste(
"\r[x] 'data' must be of class 'dataframe' or 'matrix':\n\r[-> ",
"You have supplied an argument of class '", class, "'.",
sep = ""),
"fewvariables" = paste(
"\r[x] 'data' must contain at least ", limit, " columns:\n\r[-> ",
"You have supplied a dataframe with ", cols, " columns.",
sep = ""),
"wrongdatatypes" = paste(
"\r[x] The first two columns of 'data' must be integers:\n\r[-> ",
"You have supplied columns with types ", dtypes, ".", sep = ""),
"wrongdatavalues" = paste(
"\r[x] The first two columns of 'data' must be positive:\n\r[-> ",
"Some values of the first two columns are non-positive.", sep = "")
)
}
er$notfound <- function(varname, msg) {
return(paste(
"[x] '", varname,
"' is missing or contains a non-existent variable:\n\r[-> ",
gsub("[\n]", "", msg), sep = ""))
}
er$unknown <- function(u) {
qvariable <- unname(vapply(u, sQuote, FUN.VALUE = character(1)))
qvariable <- paste(qvariable, collapse = ", ")
return(paste(
"\r[x] Unrecognized elements in the function call:\n\r[-> ",
"You have supplied values for unrecognized argument(s): ",
qvariable, ".", sep = ""))
}
er$compatibility <- function(model, n, cl) {
return(paste(
"\r[x] 'xtraclusters' must take a valid value:\n\r[-> ",
ifelse(model == "mpin",
paste("The total number of clusters in initials_mpin() is ",
"xtraclusters + layers + 1 \n\r(", cl, ") should not exceed ",
"the total number of data observations (", n, ").",
sep = ""),
paste("The total number of clusters in initials_adjpin() is",
"xtraclusters + 6 \n\r(", cl, ") should not exceed the total",
"number of data observations (", n, ").", sep = ""))
))
}
er$bayescompatibility <- function(sweeps, burnin) {
return(paste(
"\r[x] 'burnin' must take a valid value:\n\r[-> ",
paste("The value of 'burnin' (", burnin,
") should be smaller than the number of sweeps (", sweeps, ").",
sep = "")
))
}
er$mpinfn <- "MPIN estimation aborted!"
er$adjpinfn <- "AdjPIN estimation aborted!"
er$adjpininitfn <- "AdjPIN generation of initial sets aborted!"
er$mpininitfn <- "MPIN generation of initial sets aborted!"
return(er)
}
)
uiconflicts <- list(
add = function(conflicts, conflict, details = NULL) {
conflict_msgs <- list(
paste("[i] The eps_ratio condition is inactive. \neps.b and eps.s are",
" uniformly generated from their respective ranges.", sep = ""),
paste("[i] The confidence condition is inactive and the mu_ratio (",
details[1], ") is used.", sep = ""),
paste("\r[!] The range of ", details[1], " has dimension larger than 2.",
" Only the first two elements are used.", sep = ""),
paste("[!] The mu_ratio provided (", details[1], ") is too large for ",
"the mu_range (", details[2], ", ", details[3], "). It is set to ",
details[4], ".", sep = ""),
paste("[!] ", details[1], " value(s) of mu lie(s) outside the mu_range",
" provided (", details[2], ", ", details[3], ").\n\r",
"To resolve it, either set confidence = 0 or increase the",
" mu_range.", sep = "")
)
conflicts$ids <- c(conflicts$ids, conflict)
conflicts$msgs <- c(conflicts$msgs, conflict_msgs[[conflict]])
conflicts$msgs <- conflicts$msgs[order(conflicts$ids)]
conflicts$ids <- sort(conflicts$ids)
return(conflicts)
}
)
uiclasses <- list(
pin = function(object) {
ui <- list()
badge_txt <- " PIN model "
ui$badge <- paste(
"\n", ux$color(fg = 37, bg = 41, x = badge_txt), " ", sep = "")
algorithms <- list(
`YZ*` = paste("Initial parameter sets\t: Yan and Zhang (2012) ",
"as improved by Ersan and Alici (2016).\n",
"Boundary optimal points are integrated and ",
"unrealistic initial points are excluded.",
sep = ""),
YZ = "Initial parameter sets\t: Yan and Zhang (2012)",
GWJ = "Initial parameter sets\t: Gan, Wei and Johnstone (2015)",
EA = "Initial parameter sets\t: Ersan and Alici (2016)",
CUSTOM = "Initial parameter sets\t: Custom initial sets"
)
factorizations <- list(
EHO = "Likelihood factorization: Easley, Hvidkjaer and O'Hara (2010)",
LK = "Likelihood factorization: Lin and Ke (2011)",
E = "Likelihood factorization: Ersan (2016)",
NONE = "Likelihood factorization: No factorization."
)
ui$line <- "----------------------------------"
ui$algorithm <- algorithms[[object@algorithm]]
ui$factorization <- factorizations[[object@factorization]]
ui$method <- paste(
"Estimation method \t: ",
ifelse(object@method == "ML", "Maximum likelihood estimation",
"Bayesian Gibbs Sampling"), sep = "")
ui$outcome <- if (object@success)
"PIN estimation completed successfully" else
"PIN estimation failed"
ui$initialsets <- paste(
nrow(object@initialsets), "initial set(s) are used in the estimation",
"\nType object@initialsets to see the initial parameter sets used")
ui$summary <- paste("Type ", "object@details$summary[[j]]", " to see the ",
"summary of Bayesian\nestimation using the j^th initial",
"parameter set.", sep ="")
ui$markov <- paste("Type ", "object@details$markovmatrix[[j]]"," to see the ",
"matrix of Monte \nCarlo simulation of the j^th iteration.",
sep ="")
ui$failedsets <- paste("[Warning] Estimation has failed for",
nrow(object@initialsets) - object@convergent.sets,
"initial parameter set(s)!")
ui$error <- paste("\n\n", uierrors$pin()$failed, "\n\n")
ui$tablevars <- c(
"alpha", "delta", "mu", "eps.b", "eps.s", "----", "Likelihood", "PIN"
)
ui$tablevalues <- c(
ux$round1(object@parameters[1:2]),
ux$round2(object@parameters[3:5]), "",
ux$parentheses(object@likelihood),
ux$round1(object@pin)
)
ui$tableheaders <- c("Variables ", "Estimates ")
ui$runningtime <- ux$showtime(object@runningtime)
return(ui)
},
mpin = function(object) {
ui <- list()
is_ecm <- (object@method == "ECM")
is_optimal <- (object@method == "ECM" && object@optimal != 0)
# if the model is optimal for ECM, then fetch the function
# .mpin@optimaldetails to get the total number of initialsets,
# the total running time, as well as a main summary of the
# models.
if (is_optimal) {
details <- .xmpin$optimaldetails(object)
nmodels <- length(object@models)
ui$eminitialsets <- paste(
details$rinit, "initial set(s) are used for all", nmodels,
"estimations")
ui$summary <- details$tab
object@runningtime <- details$rtime
ui$tablecaption <- paste(
"Summary of", nmodels, "MPIN estimations by ECM algorithm")
txt <- " Optimal Estimation "
ui$header <- paste(" ", ux$color(fg = 37, bg = 44, x = txt), sep = "")
} else {
ui$eminitialsets <- paste(
nrow(object@initialsets),
"initial set(s) are used for the 'current' estimation",
"\nType object@initialsets to see the initial parameter sets used.")
txt <- " Regular Estimation "
ui$header <- paste(" ", ux$color(fg = 29, bg = 47, x = txt), sep = "")
}
badge_txt <- " MPIN model "
ui$badge <- paste(
"\n", ux$color(fg = 37, bg = 44, x = badge_txt), sep = "")
parallel_txt <- " Sequential "
if (.hasSlot(object, "parallel") && object@parallel)
parallel_txt <- " Parallel "
is_active <- 42
if (object@parallel && (nrow(object@initialsets) < .default$parallel_cap()))
is_active <- 41
ui$parallel <- paste(" ", ux$color(fg = 37, bg = is_active,
x = parallel_txt), " ", sep = "")
ui$algorithm <- paste("Initial parameter sets\t: Ersan (2016),",
"Ersan and Alici (2016)")
ui$factorization <- "Likelihood factorization: Ersan (2016)"
ui$method <- paste("Estimation Algorithm \t:", ifelse(!is_ecm,
"Maximum Likelihood Estimation", "Expectation Conditional Maximization"))
detectalgorithms <- list(ECM = "using Ghachem and Ersan (2022) [ECM]",
E = "using Ersan (2016)",
EG = "using Ersan and Ghachem (2022a)",
USER = "provided by the user",
INITIALSETS = "from the provided initial sets"
)
criteria <- list(
BIC = "Bayes Information Criterion (BIC)",
AIC = "Akaike Information Criterion (AIC)",
AWE = "Approximate Weight of Evidence (AWE)"
)
ui$layers <- paste(ifelse(object@detection == "USER",
"Info. layers in the data:", "Info. layers detected\t:"),
detectalgorithms[[object@detection]])
ui$line <- "----------------------------------"
ui$outcome <- if (object@success)
"MPIN estimation completed successfully" else
"MPIN estimation failed"
ui$initialsets <- paste(
nrow(object@initialsets),
"initial set(s) are used in the estimation",
"\nType object@initialsets to see the initial parameter sets used")
ui$failedsets <- paste("[Warning] Estimation has failed for",
nrow(object@initialsets) - object@convergent.sets,
"initial parameter set(s)!")
ui$criterion <- if (is_ecm)
paste("Selection criterion \t:", criteria[[object@criterion]])
ui$emfunctions <- if (is_optimal) {
paste(
"Type object@models for the estimation results for all models.",
"\nType getSummary(object) for a summary of estimates for all models."
)
}
ui$error <- paste("\n\n", uierrors$mpin()$failed, "\n")
ui$emerror <- paste("\n\n", uierrors$mpin()$emfailed, "\n")
ui$runningtime <- ux$showtime(object@runningtime)
if(object@success) {
xtablevars <- c("alpha", "delta", "mu", "eps.b", "eps.s", "----",
"Likelihood", "mpin(j)", "mpin")
if (is_ecm) xtablevars <- c(xtablevars, "----", "AIC | BIC | AWE")
ui$tablevars <- xtablevars
xtablevalues <- c(
lapply(object@parameters[1:2], ux$round1),
lapply(object@parameters[3:5], ux$round2), "",
ux$parentheses(ux$round3(object@likelihood)),
list(ux$round1(object@mpinJ)),
ux$round1(object@mpin)
)
if (is_ecm)
xtablevalues <- c(
xtablevalues, "",
list(ux$round2(c(object@AIC, object@BIC, object@AWE)))
)
ui$tablevalues <- xtablevalues
ui$tableheaders <- c("Variables ", "Estimates ")
}
return(ui)
},
adjpin = function(object) {
ui <- list()
badge_txt <- " AdjPIN model "
ui$badge <- paste(
"\n", ux$color(fg = 37, bg = 45, x = badge_txt), " ", sep = "")
initparam <- list(GE = "Ersan and Ghachem (2022b)",
CL = "Cheng and Lai (2021)",
RANDOM = "Random initial sets",
CUSTOM = "Custom initial sets")
ui$algorithm <- paste("Initial parameter sets\t:",
initparam[[object@algorithm]])
factorizations <- list(GE = "Ersan and Ghachem (2022b)",
NONE = "No factorization used")
ui$factorization <- paste(
"Likelihood factorization:", factorizations[[object@factorization]]
)
ui$method <- paste("Estimation Algorithm \t:",
ifelse(object@method == "ML",
"Maximum Likelihood Estimation",
"Expectation-Conditional Maximization"))
ui$line <- "----------------------------------"
ui$outcome <- if (object@success)
"AdjPIN estimation completed successfully" else
"AdjPIN estimation failed"
ui$initialsets <- paste(
nrow(object@initialsets), "initial set(s) are used in the estimation",
"\nType object@initialsets to see the initial parameter sets used")
ui$failedsets <- paste("[Warning] Estimation has failed for",
nrow(object@initialsets) - object@convergent.sets,
"initial parameter set(s)!")
allrestrictions <-
c("theta = theta'", "eps.b = eps.s", "mu.b = mu.s", "d.b = d.s")
# sort the list of model restrictions
restrictions <- unlist(object@restrictions[c("theta", "eps", "mu", "d")])
current_restrictions <- paste(
allrestrictions[restrictions], collapse = " & ")
if (sum(unlist(object@restrictions)) == 0)
current_restrictions <- "Unrestricted model"
ui$restrictions <- paste("Model Restrictions \t:", current_restrictions)
ui$error <- paste("\n\n", uierrors$adjpin()$failed, "\n")
ui$runningtime <- ux$showtime(object@runningtime)
ui$tablevars <- c("alpha", "delta", "theta", "theta'", "----", "eps.b",
"eps.s", "mu.b", "mu.s", "d.b", "d.s", "----",
"Likelihood", "adjPIN", "PSOS"
)
ui$tableparams <- c(lapply(object@parameters[1:4], ux$round1), "",
lapply(object@parameters[5:10], ux$round2), "",
ux$parentheses(object@likelihood),
ux$round1(object@adjpin),
ux$round1(object@psos)
)
ui$tableheaders <- c("Variables ", "Estimates ")
return(ui)
},
dataset = function(object) {
ui <- list()
badge_txt <- " Data simulation "
ui$badge <- paste(
"\n", ux$color(fg = 37, bg = 40, x = badge_txt), " ", sep = "")
is_series <- (.hasSlot(object, "series"))
if (is_series)
ui$badge <- paste(ui$badge, "\n")
is_mpin <- (object@model == "MPIN")
ui$model <- paste("Simulation model \t:",
ifelse(object@model == "MPIN", "MPIN model",
"AdjPIN model"))
ui$line <- "----------------------------------"
ui$outcome <- ifelse(is_series,
"Simulated data successfully generated",
"Data series successfully generated")
ui$days <- paste("Number of trading days\t:",
ux$sep(object@days), "days")
ui$layers <- paste("Number of layers\t:", ifelse(
max(object@layers) > min(object@layers),
paste("random from 1 to", max(object@layers)),
paste(min(object@layers), "layer(s)")
))
ui$getdata <- ifelse(
is_series, "Type object@datasets to access the list of dataset objects",
"Type object@data to get the simulated data")
allrestrictions <- c(
"theta = theta'", "eps.b = eps.s", "mu.b = mu.s", "d.b = d.s")
# sort the list of model restrictions
restrictions <- unlist(object@restrictions[c("theta", "eps", "mu", "d")])
current_restrictions <- paste(
allrestrictions[restrictions], collapse = " & ")
if (sum(unlist(object@restrictions)) == 0)
current_restrictions <- "Unrestricted model"
ui$restrictions <- if (object@model == "adjPIN")
paste("Model Restrictions \t:", current_restrictions)
ui$runningtime <- ux$showtime(object@runningtime)
## data.series specific ui
dataseries_warnings <- c(
"[info] The eps_ratio condition is inactive.",
"[info] The confidence interval condition is inactive.",
"[Warning] Some ranges have dimension larger than 2!",
paste(
"[Warning] Some datasets have a conflict between mu",
"range and mu_ratio!"
),
paste(
"[Warning] Some datasets suffer from a conflict between",
"confidence interval and mu range!"
)
)
ui$datasets <- if (is_series)
paste("Number of datasets\t:", object@series, "datasets")
ui$warnings <- if (is_series)
paste(dataseries_warnings[object@warnings], collapse = "\n")
if (!is_series) {
tablevars <- c(
"alpha", "delta", "theta", "theta'", "----", "eps.b", "eps.s", "mu.b",
"mu.s", "d.b", "d.s", "----", "Likelihood", "adjPIN", "PSOS"
)
if (is_mpin)
tablevars <- c("alpha", "delta", "mu", "eps.b", "eps.s", "----",
"Likelihood", "mpin")
ui$tablevars <- tablevars
tablevalues <- NULL
if (is_mpin) {
# Theoretical values
tablevalues <- c(lapply(object@theoreticals[1:2], ux$round1),
lapply(object@theoreticals[3:5], ux$round2),
"", "-", "-")
# Empirical values
tablevalues <- cbind(
tablevalues,
c(lapply(object@empiricals[1:2], ux$round1),
lapply(object@empiricals[3:5], ux$round2),
"", ux$parentheses(ux$round3(object@likelihood)),
ux$round1(object@emp.pin)))
# Aggregate values
tablevalues <- cbind(
tablevalues,
c(lapply(object@aggregates[1:2], ux$round1),
lapply(object@aggregates[3:5], ux$round2), "",
ux$parentheses(ux$round3(object@likelihood)),
ux$round1(object@emp.pin)))
} else {
tablevalues <- cbind(
c(lapply(object@theoreticals[1:4], ux$round1), "",
lapply(object@theoreticals[5:10], ux$round2), "", "",
lapply(object@theoreticals[11:12], ux$round3)
),
c(lapply(object@empiricals[1:4], ux$round1), "",
lapply(object@empiricals[5:10], ux$round2), "",
ux$parentheses(ux$round3(object@likelihood)),
lapply(object@empiricals[11:12], ux$round3)
)
)
}
ui$tablevalues <- tablevalues
headers <- c("Variables ", "Theoretical. ", "Empirical. ")
if (is_mpin) headers <- c(headers, "Aggregates. ")
ui$tableheaders <- headers
}
return(ui)
},
emsummary = function(object) {
ui <- list()
models <- attr(object, "models")
xmodels <- length(models)
ui$line <- "----------------------------------"
ui$tablecaption <- paste(
"Summary of MPIN estimations by the ECM algorithm : [",
xmodels, " models]", sep = "")
xsummary <- NULL
for (i in seq_len(xmodels)) {
xmodel <- models[[i]]
xsummary <- rbind(xsummary, c(
round(c(i, xmodel@layers, xmodel@mpin, xmodel@likelihood), 3),
round(c(xmodel@AIC, xmodel@BIC, xmodel@AWE), 1)))
}
ui$tablevalues <- xsummary
ui$tableheaders <- c("layers", "em.layers", "MPIN", "Likelihood",
"AIC", "BIC", "AWE")
ui$tablerows <- c(paste("Model[", seq_len(xmodels), "]", sep = ""))
ui$nothing <- "A single model has been estimated, so nothing to summarize!"
return(ui)
},
getmodels = function() {
ui <- list()
ui$nomodels <- "A single model has been estimated, so no models to show!"
return(ui)
},
vpin = function(object) {
ui <- list()
badge_txt <- " VPIN model "
ui$badge <- paste(
"\n", ux$color(fg = 37, bg = 46, x = badge_txt), " ", sep = "")
ui$line <- "----------------------------------"
ui$outcome <- if (object@success)
"VPIN estimation completed successfully" else
"VPIN estimation failed"
ui$vpinfunctions <- paste(
"Type object@vpin to access the VPIN vector.",
"\nType object@bucketdata to access data used to construct",
"the VPIN vector.",
"\nType object@dailyvpin to access the daily VPIN vectors.")
vpinsummary <- unclass(summary(object@vpin))
vpinnames <- names(vpinsummary)
vpinsummary <- data.frame(t(ux$round3(vpinsummary)))
colnames(vpinsummary) <- vpinnames
ui$vpinsummary <- vpinsummary
ui$summarycaption <- "\r[+] VPIN descriptive statistics"
vpinparams <- data.frame(matrix(object@parameters, ncol = 5))
colnames(vpinparams) <- names(object@parameters)
rownames(vpinparams) <- NULL
ui$vpinparams <- vpinparams
ui$paramscaption <- "\r[+] VPIN parameters"
ui$error <- paste("\n\n", uierrors$vpin()$failed, "\n\n")
ui$runningtime <- ux$showtime(object@runningtime)
return(ui)
}
)
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.