#' get.default.parameters
#'
#' @keywords internal
#'
get.default.parameters <- function(mcall, myFormals) {
## formals with default arguments
for ( v in names(myFormals)){
if (!(v %in% names(mcall)))
mcall[v] <- myFormals[v] ## if arg is missing I add it
}
return(mcall)
}
#' select_on_class
#'
#' @keywords internal
#'
select_on_class <- function(.data, clases = "numeric") {
.data[, sapply(.data, function(vec, clss) any(class(vec) %in% clss), clss = clases), drop = FALSE]
}
#' contr.dummy
#'
#' @keywords internal
#'
kknn.contr.dummy <- function (n, contrasts = TRUE) {
if (length(n) <= 1) {
if (is.numeric(n) && length(n) == 1 && n > 1)
levels <- 1:n
else stop("contrasts are not defined for 0 degrees of freedom")
}
else levels <- n
lenglev <- length(levels)
cont <- array(0, c(lenglev, lenglev), list(levels, levels))
cont[col(cont) == row(cont)] <- 1
cont
}
#' contr.ordinal
#'
#' @keywords internal
#'
kknn.contr.ordinal <- function (n, contrasts = TRUE) {
if (length(n) <= 1) {
if (is.numeric(n) && length(n) == 1 && n > 1)
levels <- 1:n
else stop("contrasts are not defined for 0 degrees of freedom")
}
else levels <- n
lenglev <- length(levels)
cont <- array(0.5, c(lenglev, lenglev - 1), list(levels,
NULL))
cont[lower.tri(cont)] <- -0.5
cont
}
#' max_col
#'
#' @keywords internal
#'
max_col <- function(m){
base::max.col(apply(m, 1, function(x) max(x, na.rm = TRUE)) == m)
}
#' numeric_to_predict
#'
#' @keywords internal
#'
numeric_to_predict <- function(real, predic.var = NULL, niveles = NULL) {
if(is.numeric(predic.var)) {
if(is.null(niveles)){
numCategories <- length(levels(real))
#We must specify the possible values that the factor type object can take
#Then we specify the labels that must have the same size as the levels
predic.var <- factor(predic.var, levels = 1:numCategories,labels = levels(real))
}
else{
numCategories <- length(niveles)
predic.var <- factor(predic.var, levels = 1:numCategories,labels = niveles)
}
}
predic.var
}
#' type_correction
#'
#' @keywords internal
#'
type_correction <- function(model, prediction, fix){
var_type <- model$prmdt$type
.levels <- model$prmdt$levels
if(var_type != "numeric" && var_type != "integer" && fix){
names(prediction) <- NULL
return(factor(prediction, levels = .levels))
}else{
return(prediction)
}
}
#' original_model
#'
#' @keywords internal
#'
original_model <- function(x){
class(x) <- class(x)[!str_detect(class(x), "prmdt")]
x$prmdt <- NULL
return(x)
}
#' get_test_less_predict
#'
#' @keywords internal
#'
get_test_less_predict <- function(data, var.pred){
if(var.pred %in% colnames(data)){
return(data[,-which(colnames(data) == var.pred)])
}
return(data)
}
#' Printing prmdt models
#'
#' @param x A prmdt models
#' @param ... optional arguments to print o format method
#'
#' @return a print information of a model.
#'
#' @export print.prmdt
#' @export
#'
print.prmdt <- function(x, ...){
print(original_model(x), ...)
}
#' Printing prmdt prediction object
#'
#' @param x A prmdt prediction object
#' @param ... optional arguments to print o format method
#'
#' @return a print prediction of a model.
#'
#' @export print.prediction.prmdt
#' @export
#'
print.prediction.prmdt <- function(x, ...){
print(x$prediction, ...)
}
#' Printing prmdt index object
#'
#' @param x A prmdt index object
#' @param ... optional arguments to print o format method
#'
#' @importFrom utils capture.output
#'
#' @return a print of the results of a prediction model.
#'
#' @export print.indexes.prmdt
#' @export
#'
print.indexes.prmdt <- function(x, ...) {
if(is.null(x$confusion.matrix)) {
out <- paste(capture.output(unlist(x)), collapse = "\n")
} else {
out <- c("\nConfusion Matrix:",capture.output(x$confusion.matrix))
out <- paste(out, collapse = "\n")
out <- paste0(out, sprintf("\n\nOverall Accuracy: %3.4f\nOverall Error: %9.4f\n", x$overall.accuracy, x$overall.error))
out.aux <- do.call(sprintf, c(paste0(rep("%13s", length(x$category.accuracy)), collapse = ""), as.list(names(x$category.accuracy))))
out.aux <- paste0("\nCategory Accuracy:\n\n",out.aux, "\n",
do.call(sprintf, c(paste0(rep("%13f", length(x$category.accuracy)), collapse = ""), as.list(as.numeric(x$category.accuracy)))))
out <- paste0(out, out.aux)
}
cat(out)
}
#' Plotting prmdt models
#'
#' @param x A prmdt models
#' @param ... optional arguments to print o format method
#'
#' @return a plot of a model.
#'
#' @export plot.prmdt
#' @export
#'
plot.prmdt <- function(x, ...){
x <- original_model(x)
plot(x, ...)
}
#' Plotting prmdt ada models
#'
#' @param x A ada prmdt model
#' @param ... optional arguments to print o format method
#'
#' @return a plot of the importance of variables.
#'
#' @export
#'
varplot <- function(x, ...){
x <- original_model(x)
ada::varplot(x, ...)
}
#' dummy
#'
#' function from dummies package
#'
#' @keywords internal
#'
dummy <- function (x, data = NULL, sep = "", drop = TRUE, fun = as.integer,
verbose = FALSE)
{
if (is.null(data)) {
name <- as.character(sys.call(1))[2]
name <- sub("^(.*\\$)", "", name)
name <- sub("\\[.*\\]$", "", name)
}
else {
if (length(x) > 1)
stop("More than one variable provided to produce dummy variable.")
name <- x
x <- data[, name]
}
if (drop == FALSE && class(x) == "factor") {
x <- factor(x, levels = levels(x), exclude = NULL)
}
else {
x <- factor(x, exclude = NULL)
}
if (length(levels(x)) < 2) {
if (verbose)
warning(name, " has only 1 level. Producing dummy variable anyway.")
return(matrix(rep(1, length(x)), ncol = 1, dimnames = list(rownames(x),
c(paste(name, sep, x[[1]], sep = "")))))
}
mm <- model.matrix(~x - 1, model.frame(~x - 1), contrasts = FALSE)
colnames.mm <- colnames(mm)
if (verbose)
cat(" ", name, ":", ncol(mm), "dummy varibles created\n")
mm <- matrix(fun(mm), nrow = nrow(mm), ncol = ncol(mm), dimnames = list(NULL,
colnames.mm))
colnames(mm) <- sub("^x", paste(name, sep, sep = ""), colnames(mm))
if (!is.null(row.names(data)))
rownames(mm) <- rownames(data)
return(mm)
}
#' dummy.data.frame
#'
#' function from dummies package
#'
#' @keywords internal
#'
dummy.data.frame <- function (data, names = NULL, omit.constants = TRUE, dummy.classes = getOption("dummy.classes"),
all = TRUE, ...)
{
df <- data.frame(row.names = row.names(data))
new.attr <- list()
for (nm in names(data)) {
old.attr <- attr(df, "dummies")
if (nm %in% names || (is.null(names) && (dummy.classes ==
"ALL" || class(data[, nm]) %in% dummy.classes))) {
dummies <- dummy(nm, data, ...)
if (ncol(dummies) == 1 & omit.constants) {
dummies <- matrix(nrow = nrow(data), ncol = 0)
}
if (ncol(dummies) > 0)
new.attr[[nm]] <- (ncol(df) + 1):(ncol(df) +
ncol(dummies))
}
else {
if (!all)
(next)()
dummies <- data[, nm, drop = FALSE]
}
df <- cbind(df, dummies)
}
attr(df, "dummies") <- new.attr
return(df)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.