Nothing
R/99_HELPERS.R
In monobinShiny: Shiny User Interface for 'monobin' Package
Defines functions
monobin.run
monobin.fun
mono.inputs.check
num.inputs
desc.report
out.impute
sc.impute
sc.check
check.vars
algo.ui
woe.ui
pct.ui
ndr.sts.ui
iso.ui
cum.ui
mdt.ui
Documented in
algo.ui
check.vars
cum.ui
desc.report
iso.ui
mdt.ui
monobin.fun
monobin.run
mono.inputs.check
ndr.sts.ui
num.inputs
out.impute
pct.ui
sc.check
sc.impute
woe.ui
#' mdt.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the iso.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
mdt.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
numericInput(inputId = ns("arg2"),
label = "Number of splitting groups for each node",
value = 50,
min = 2,
max = 150),
selectInput(inputId = ns("arg3"),
label = "How to treat special cases?",
choices = c("together", "separately")),
selectInput(inputId = ns("arg4"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
numericInput(inputId = ns("arg5"),
label = "Minimum pct. of observations per bin",
value = 0.05,
min = 0,
max = 1),
numericInput(inputId = ns("arg6"),
label = "Minimum avg. target rate per bin",
value = 0.01,
min = 0,
max = 1),
selectInput(inputId = ns("arg7"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' cum.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the cum.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
cum.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
numericInput(inputId = ns("arg3"),
label = "Number of starting groups",
value = 15,
min = 2,
max = 40),
selectInput(inputId = ns("arg4"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
selectInput(inputId = ns("arg5"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' iso.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the iso.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
iso.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
selectInput(inputId = ns("arg3"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
numericInput(inputId = ns("arg4"),
label = "Minimum pct. of observations per bin",
value = 0.05,
min = 0,
max = 1),
numericInput(inputId = ns("arg5"),
label = "Minimum avg. target rate per bin",
value = 0.01,
min = 0,
max = 1),
selectInput(inputId = ns("arg6"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' ndr.bin / sts.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the ndr.bin / sts.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
ndr.sts.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
selectInput(inputId = ns("arg3"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
numericInput(inputId = ns("arg4"),
label = "Minimum pct of observations per bin",
value = 0.05,
min = 0,
max = 1),
numericInput(inputId = ns("arg5"),
label = "Minimum avg target rate per bin",
value = 0.01,
min = 0,
max = 1),
numericInput(inputId = ns("arg6"),
label = "p-value",
value = 0.05,
min = 0,
max = 1),
selectInput(inputId = ns("arg7"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' pct.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the pct.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
pct.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
numericInput(inputId = ns("arg3"),
label = "Number of starting groups",
value = 15,
min = 2,
max = 40),
selectInput(inputId = ns("arg4"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
selectInput(inputId = ns("arg5"),
label = HTML("Force WoE trend</br>
(applied only for continuous target)"),
choices = c(TRUE, FALSE)),
selectInput(inputId = ns("arg6"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' woe.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the woe.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
woe.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
selectInput(inputId = ns("arg3"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
numericInput(inputId = ns("arg4"),
label = "Minimum pct of observations per bin",
value = 0.05,
min = 0,
max = 1),
numericInput(inputId = ns("arg5"),
label = "Minimum avg target rate per bin",
value = 0.01,
min = 0,
max = 1),
numericInput(inputId = ns("arg6"),
label = "WoE threshold",
value = 0.1,
min = 0,
max = 1),
selectInput(inputId = ns("arg7"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' Server side for monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, server side call for user interface of the selected binning algorithm.
#'
#'@examples
#' if (interactive()) {
#' algo.ui(id = "monobin")
#' }
#'@export
algo.ui <- function(id) {
moduleServer(id, function(input, output, session) {
observeEvent(input$monobin.method, {
algo.select <- input$monobin.method
output$algo.args <- renderUI({
tagList(switch(algo.select,
"cum.bin" = cum.ui(id = id),
"iso.bin" = iso.ui(id = id),
"ndr.bin" = ndr.sts.ui(id = id),
"sts.bin" = ndr.sts.ui(id = id),
"pct.bin" = pct.ui(id = id),
"woe.bin" = woe.ui(id = id),
"mdt.bin" = mdt.ui(id = id)))
})
})
})
}
#' Check for categorical variables when importing the data
#'@param tbl Imported data frame.
#'@return Returns a character vector which describes variables type of imported data frame.
#'
#'@examples
#' if (interactive()) {
#' check.msg <- check.vars(tbl = rv$db)
#' }
#'@export
check.vars <- function(tbl) {
check <- !sapply(tbl, is.numeric)
check.col <- names(tbl)[check]
if (length(check.col) == 0) {
msg <- "All variables of numeric type."
} else {
cols <- paste(check.col, collapse = ", ")
msg <- paste0("Following variables identified as non-numeric:",
cols, ".")
}
return(msg)
}
#' Special cases - check input values
#'@param x Numeric vector of special case values.
#'@return Returns a list of three vectors: special case input(s) converted to numeric type,
#' number of special case input(s) that cannot be converted to
#' numeric type (including \code{NA}, \code{NaN} and \code{Inf}) and special case input(s)
#' that cannot be converted to numeric type.
#'
#'@examples
#' if (interactive()) {
#' sca.check.res <- sc.check(x = input$sc.all)
#' scr.check.res <- sc.check(x = input$sc.replace)
#' }
#'sc.check(x = "NA, NaN, Inf")
#'sc.check(x = "NA, abc")
#'sc.check(x = "NaN, abc")
#'sc.check(x = "Inf, abc")
#'sc.check(x = "9999999999, abc")
#'sc.check(x = "NA, NaN, Inf, 9999999999")
#'@export
sc.check <- function(x) {
if (""%in%x) {
return(list(NULL, 2, "Empty input field."))
}
if (is.na(x)) {
sc <- NA
} else {
sc <- trimws(strsplit(x, ",")[[1]])
}
if (length(sc) == 1) {
if (is.na(x) | is.infinite(x)) {
return(list(x, 0, x))
}
if (!sc%in%c("NA", "NaN", "Inf") & suppressWarnings(is.na(as.numeric(sc)))) {
return(list(NULL, 2, sc))
}
}
sc.num <- suppressWarnings(as.numeric(sc))
check.01 <- is.na(sc.num)
check.02 <- is.nan(sc.num)
check.99 <- check.01 & !check.02
check.val <- sc[check.99]
if (length(check.val) > 0) {
if (length(check.val) == 1) {
if (check.val != "NA") {
check.sum <- 2
} else {
check.sum <- 1
}
} else {
check.sum <- sum(check.99)
}
} else {
check.sum <- 0
}
return(list(sc.num, check.sum, check.val))
}
#' Special case imputation
#'@param tbl Data frame with risk factors ready for imputation.
#'@param rf Vector of risk factors to be imputed.
#'@param sc Numeric vector of special case values.
#'@param sc.replace Numeric vector of special case values that are selected for imputation.
#'@param imp.method Imputation method (mean or median).
#'@return Returns a list of three elements. The first element is a data frame with imputed values,
#' the second element is a vector of newly created risk factors (with imputed values) and the third one is
#' a data frame with information about possible imputation errors.
#'
#'@examples
#' if (interactive()) {
#' imp.res <- suppressWarnings(
#' sc.impute(tbl = rv$db,
#' rf = rf,
#' sc = sca.check.res[[1]],
#' sc.replace = scr.check.res[[1]],
#' imp.method = imp.method)
#' )
#' }
#'
#'@export
sc.impute <- function(tbl, rf, sc, sc.replace, imp.method) {
rfl <- length(rf)
rfn <- paste0(rf, "_sc_", imp.method)
rfn.f <- rfn
info.tbl <- vector("list", rfl)
info.msg <- "Imputed value cannot be calculated properly.
Selected risk factor is not processed.
Check the risk factor manually."
eval.exp <- paste0(imp.method, "(rf.imp[!rf.imp%in%sc])")
for (i in 1:rfl) {
rf.l <- rf[i]
rfn.l <- rfn[i]
rf.imp <- tbl[, rf.l]
rf.imp.val <- eval(parse(text = eval.exp))
if (rf.imp.val%in%c(NA, Inf, NaN)) {
info.tbl[[i]] <- data.frame(risk.factor = rf.l,
info = info.msg,
imputation.method = imp.method)
rfn.f <- rfn.f[!rfn.f%in%rfn.l]
next
} else {
rf.imp[rf.imp%in%sc.replace] <- rf.imp.val
if (rfn.l%in%names(tbl)) {
tbl[, rfn.l] <- rf.imp
} else {
tbl <- cbind.data.frame(tbl, rf.imp)
names(tbl)[ncol(tbl)] <- rfn.l
}
}
}
info.tbl <- bind_rows(info.tbl)
return(list(tbl, rf.imp = rfn.f, info = data.frame(info.tbl)))
}
#' Outliers imputation
#'@param tbl Data frame with risk factors ready for imputation.
#'@param rf Vector of risk factors to be imputed.
#'@param ub Upper bound percentiles.
#'@param lb Lower bound percentiles.
#'@param sc Numeric vector of special case values.
#'@return Returns a list of three elements. The first element is a data frame with imputed values,
#' the second element is a vector of newly created risk factors (with imputed values) and the third one is
#' a data frame with information about possible imputation errors.
#'
#'@examples
#' if (interactive()) {
#' imp.res <- suppressWarnings(
#' out.impute(tbl = rv$db,
#' rf = input$rf.out,
#' ub = upper.pct,
#' lb = lower.pct,
#' sc = sca.check.res[[1]])
#' )
#' }
#'
#'@export
out.impute <- function(tbl, rf, ub, lb, sc) {
rfl <- length(rf)
rfn <- paste0(rf, "_out_", ub, "_", lb)
rfn.f <- rfn
info.tbl <- vector("list", rfl)
info.msg <- "Imputed outlier value(s) cannot be calculated properly.
Selected risk factor is not processed.
Check the risk factor manually."
for (i in 1:rfl) {
rf.l <- rf[i]
rfn.l <- rfn[i]
rf.imp <- tbl[, rf.l]
complete.c <- rf.imp[!rf.imp%in%sc]
rf.imp.ub <- try(quantile(complete.c, ub), silent = TRUE)
rf.imp.lb <- try(quantile(complete.c, lb), silent = TRUE)
cond <- class(rf.imp.ub)%in%"try-error" | class(rf.imp.lb)%in%"try-error" |
rf.imp.ub%in%c(NA, Inf, NaN) | rf.imp.lb%in%c(NA, Inf, NaN)
if (cond) {
info.tbl[[i]] <- data.frame(risk.factor = rf.l,
info = info.msg,
pct.selected = paste0("upper bound = ", ub,
"; lower bound = ", lb))
rfn.f <- rfn.f[!rfn.f%in%rfn.l]
next
} else {
rf.imp[!rf.imp%in%sc & rf.imp > rf.imp.ub] <- rf.imp.ub
rf.imp[!rf.imp%in%sc & rf.imp < rf.imp.lb] <- rf.imp.lb
if (rfn.l%in%names(tbl)) {
tbl[, rfn.l] <- rf.imp
} else {
tbl <- cbind.data.frame(tbl, rf.imp)
names(tbl)[ncol(tbl)] <- rfn.l
}
}
}
info.tbl <- bind_rows(info.tbl)
return(list(tbl, rf.imp = rfn.f, info = data.frame(info.tbl)))
}
#' Descriptive statistics report
#'@param target Selected target.
#'@param rf Vector of a selected numeric risk factors.
#'@param sc Numeric vector of special case values.
#'@param sc.method Define how special cases will be treated, all together or in separate bins.
#'@param db Data frame of target and numeric risk factors.
#'@return Returns a data frame with descriptive statistics for the selected risk drivers.
#'
#'@examples
#' if (interactive()) {
#' srv$desc.stat <- withProgress(message = "Running descriptive statistics report",
#' value = 0, {
#' desc.report(target = "qual",
#' rf = rf,
#' sc = sc,
#' sc.method = sc.method,
#' db = isolate(rv$db))
#' })
#' }
#'
#'@export
desc.report <- function(target, rf, sc, sc.method, db) {
y <- db[, target]
rfl <- length(rf)
res <- vector("list", rfl)
for (i in 1:rfl) {
rf.n <- rf[i]
incProgress(1 / (rfl - i + 1), detail = paste("Processing risk factor:", rf.n))
x <- db[, rf.n]
desc.l <- suppressWarnings(
desc.stat(y = y,
x = x,
sc = sc,
sc.method = sc.method)
)
desc.l <- cbind.data.frame(risk.factor = rf.n, desc.l)
res[[i]] <- desc.l
}
res <- data.frame(bind_rows(res))
return(res)
}
#' Numeric arguments - monobin module
#'@param x Binning algorithm from monobin package.
#'@return Returns a list of two vectors: index and UI element label of numeric arguments of
#' the selected monobin function.
#'@examples
#' if (interactive()) {
#' inp.indx <- num.inputs(x = x)
#' }
#' num.inputs(x = "cum.bin")
#'
#'@export
num.inputs <- function(x) {
switch(x,
"cum.bin" = list(3, "Number of starting groups"),
"iso.bin" = list(c(4, 5), c("Minimum pct. of observations per bin",
"Minimum avg. target rate per bin")),
"ndr.bin" = list(c(4, 5, 6), c("Minimum pct. of observations per bin",
"Minimum avg. target rate per bin",
"p-value")),
"pct.bin" = list(3, "Number of starting groups"),
"sts.bin" = list(c(4, 5, 6), c("Minimum pct. of observations per bin",
"Minimum avg. target rate per bin",
"p-value")),
"woe.bin" = list(c(4, 5, 6), c("Minimum pct. of observations per bin",
"Minimum avg. target rate per bin",
"WoE threshold")),
"mdt.bin" = list(c(2, 5, 6), c("Number of splitting groups for each node",
"Minimum pct. of observations per bin",
"Minimum avg. target rate per bin")))
}
#' Check for numeric arguments - monobin module
#'@param x Binning algorithm from monobin package.
#'@param args.e Argument elements of the selected monobin function.
#'@return Returns a list of two vectors: logical if validation is successful and character vector
#' with validation message.
#'@examples
#' if (interactive()) {
#' num.inp <- mono.inputs.check(x = bin.algo, args.e = args.e)
#' }
#'
#'@export
mono.inputs.check <- function(x, args.e) {
inp.indx <- num.inputs(x = x)
num.args <- c(args.e[inp.indx[[1]]], recursive = TRUE)
check.01 <- any(is.na(num.args))
if (check.01) {
msg <- paste0("Numeric input(s) required for: ",
paste0(paste0("#", inp.indx[[2]], "#"), collapse = ", "), ".")
return(list(check.ok = FALSE, msg = msg))
}
if (x%in%c("cum.bin", "pct.bin")) {
if (num.args[1] < 2 | num.args[1] > 40) {
msg <- paste0("Input #Number of starting groups# has to be between 2 and 40.")
return(list(check.ok = FALSE, msg = msg))
}
}
if (x%in%c("iso.bin", "woe.bin")) {
if (any(num.args[1:2] < 0) | any(num.args[1:2] > 0.5)) {
msg <- paste0("Inputs: ",
paste0(paste0("#", inp.indx[[2]][1:2], "#"), collapse = ", "),
" have to be between 0 and 0.5")
return(list(check.ok = FALSE, msg = msg))
}
}
if (x%in%c("ndr.bin", "sts.bin")) {
if (any(num.args[1:2] < 0) | any(num.args[1:2] > 0.5)) {
msg <- paste0("Inputs: ",
paste0(paste0("#", inp.indx[[2]][1:2], "#"), collapse = ", "),
" have to be between 0 and 0.5")
return(list(check.ok = FALSE, msg = msg))
}
if (num.args[3] < 0.001 | num.args[3] > 0.2) {
msg <- paste0("Input #p-value# has to be between 0.001 and 0.2")
return(list(check.ok = FALSE, msg = msg))
}
}
if (x%in%c("mdt.bin")) {
if (num.args[1] < 2 | num.args[1] > 150) {
msg <- paste0("Input #Number of splitting groups for each node# has to be between 2 and 150.")
return(list(check.ok = FALSE, msg = msg))
}
if (any(num.args[2:3] < 0) | any(num.args[2:3] > 0.5)) {
msg <- paste0("Inputs: ",
paste0(paste0("#", inp.indx[[2]][2:3], "#"), collapse = ", "),
" have to be between 0 and 0.5")
return(list(check.ok = FALSE, msg = msg))
}
}
return(list(check.ok = TRUE, msg = "Inputs validated."))
}
#' Evaluation expression of the selected monobin function and its arguments
#'@param x Binning algorithm from monobin package.
#'@return Returns an evaluation expression of the selected monobin algorithm.
#'@examples
#' if (interactive()) {
#' expr.eval <- monobin.fun(x = algo)
#' }
#' monobin.fun(x = "ndr.bin")
#'
#'
#'@export
monobin.fun <- function(x) {
switch(x,
"cum.bin" = "cum.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], g = args.e[[3]],
y.type = args.e[[4]], force.trend = args.e[[5]])",
"iso.bin" = "iso.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], y.type = args.e[[3]],
min.pct.obs = args.e[[4]], min.avg.rate = args.e[[5]],
force.trend = args.e[[6]])",
"ndr.bin" = "ndr.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], y.type = args.e[[3]],
min.pct.obs = args.e[[4]], min.avg.rate = args.e[[5]],
p.val = args.e[[6]], force.trend = args.e[[7]])",
"pct.bin" = "pct.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], g = args.e[[3]],
y.type = args.e[[4]], woe.trend = args.e[[5]],
force.trend = args.e[[6]])",
"sts.bin" = "sts.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], y.type = args.e[[3]],
min.pct.obs = args.e[[4]], min.avg.rate = args.e[[5]],
p.val = args.e[[6]], force.trend = args.e[[7]])",
"woe.bin" = "woe.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], y.type = args.e[[3]],
min.pct.obs = args.e[[4]], min.avg.rate = args.e[[5]],
woe.gap = args.e[[6]], force.trend = args.e[[7]])",
"mdt.bin" = "mdt.bin(y = target, x = rf.l, sc = sc, g = args.e[[2]],
sc.method = args.e[[3]], y.type = args.e[[4]],
min.pct.obs = args.e[[5]], min.avg.rate = args.e[[6]],
force.trend = args.e[[7]])")
}
#' Run monobin algorithm for the selected inputs
#'@param algo Binning algorithm from monobin package.
#'@param target.n Selected target.
#'@param rf Vector of a selected numeric risk factors.
#'@param sc Numeric vector of special case values.
#'@param args.e Argument elements of the selected monobin function.
#'@param db Data frame of target and numeric risk factors.
#'@return Returns a list of two data frame. The first data frame contains the results of implemented
#' binning algorithm, while the second one contains transformed risk factors.
#'@examples
#' if (interactive()) {
#' tbls <- withProgress(message = "Running the binning algorithm",
#' value = 0, {
#' suppressWarnings(
#' monobin.run(algo = bin.algo,
#' target.n = isolate(input$trg.select),
#' rf = isolate(input$rf.select),
#' sc = scr.check.res[[1]],
#' args.e = args.e,
#' db = isolate(rv$db))
#' )})
#'
#' }
#'
#'@export
monobin.run <- function(algo, target.n, rf, sc, args.e, db) {
target <- db[, target.n]
expr.eval <- monobin.fun(x = algo)
rfl <- length(rf)
res <- vector("list", rfl)
res.trans <- vector("list", rfl)
for (i in 1:rfl) {
rf.n <- rf[i]
incProgress(1 / (rfl - i + 1), detail = paste("Processing risk factor:", rf.n))
rf.l <- db[, rf.n]
res.l <- eval(parse(text = expr.eval))
if (length(res.l) == 1) {
res.tbl <- res.l[1]
res.trans[[i]] <- NULL
} else {
res.tbl <- res.l[[1]]
res.trans[[i]] <- data.frame(x = res.l[[2]])
names(res.trans[[i]]) <- rf.n
}
res.tbl <- cbind.data.frame(risk.factor = rf.n, res.tbl)
res[[i]] <- res.tbl
}
res <- bind_rows(res)
res.trans <- bind_cols(res.trans)
if (nrow(res.trans) == 0) {
res.trans <- cbind.data.frame(target = target)
} else {
res.trans <- cbind.data.frame(target = target, res.trans)
}
names(res.trans)[1] <- target.n
return(list(res, res.trans))
}
Try the monobinShiny package in your browser
Any scripts or data that you put into this service are public.
monobinShiny documentation built on Nov. 22, 2021, 9:07 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions monobin.run monobin.fun mono.inputs.check num.inputs desc.report out.impute sc.impute sc.check check.vars algo.ui woe.ui pct.ui ndr.sts.ui iso.ui cum.ui mdt.ui
Documented in algo.ui check.vars cum.ui desc.report iso.ui mdt.ui monobin.fun monobin.run mono.inputs.check ndr.sts.ui num.inputs out.impute pct.ui sc.check sc.impute woe.ui
#' mdt.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the iso.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
mdt.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
numericInput(inputId = ns("arg2"),
label = "Number of splitting groups for each node",
value = 50,
min = 2,
max = 150),
selectInput(inputId = ns("arg3"),
label = "How to treat special cases?",
choices = c("together", "separately")),
selectInput(inputId = ns("arg4"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
numericInput(inputId = ns("arg5"),
label = "Minimum pct. of observations per bin",
value = 0.05,
min = 0,
max = 1),
numericInput(inputId = ns("arg6"),
label = "Minimum avg. target rate per bin",
value = 0.01,
min = 0,
max = 1),
selectInput(inputId = ns("arg7"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' cum.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the cum.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
cum.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
numericInput(inputId = ns("arg3"),
label = "Number of starting groups",
value = 15,
min = 2,
max = 40),
selectInput(inputId = ns("arg4"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
selectInput(inputId = ns("arg5"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' iso.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the iso.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
iso.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
selectInput(inputId = ns("arg3"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
numericInput(inputId = ns("arg4"),
label = "Minimum pct. of observations per bin",
value = 0.05,
min = 0,
max = 1),
numericInput(inputId = ns("arg5"),
label = "Minimum avg. target rate per bin",
value = 0.01,
min = 0,
max = 1),
selectInput(inputId = ns("arg6"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' ndr.bin / sts.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the ndr.bin / sts.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
ndr.sts.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
selectInput(inputId = ns("arg3"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
numericInput(inputId = ns("arg4"),
label = "Minimum pct of observations per bin",
value = 0.05,
min = 0,
max = 1),
numericInput(inputId = ns("arg5"),
label = "Minimum avg target rate per bin",
value = 0.01,
min = 0,
max = 1),
numericInput(inputId = ns("arg6"),
label = "p-value",
value = 0.05,
min = 0,
max = 1),
selectInput(inputId = ns("arg7"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' pct.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the pct.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
pct.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
numericInput(inputId = ns("arg3"),
label = "Number of starting groups",
value = 15,
min = 2,
max = 40),
selectInput(inputId = ns("arg4"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
selectInput(inputId = ns("arg5"),
label = HTML("Force WoE trend</br>
(applied only for continuous target)"),
choices = c(TRUE, FALSE)),
selectInput(inputId = ns("arg6"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' woe.bin - monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, called for user interface of the woe.bin - monobin functions' inputs.
#'
#'@examples
#' if (interactive()) {
#' output$algo.args <- renderUI({tagList(switch(algo.select, "cum.bin" = cum.ui(id = id),
#' "iso.bin" = iso.ui(id = id),
#' "ndr.bin" = ndr.sts.ui(id = id),
#' "sts.bin" = ndr.sts.ui(id = id),
#' "pct.bin" = pct.ui(id = id),
#' "woe.bin" = woe.ui(id = id),
#' "mdt.bin" = mdt.ui(id = id)))
#' })
#' }
#'@export
woe.ui <- function(id) {
ns <- NS(id)
column(12,
textInput(inputId = ns("arg1"),
label = "Special case elements",
value = "NA, NaN, Inf"),
selectInput(inputId = ns("arg2"),
label = "How to treat special cases?",
choices = c("together", "separately")),
selectInput(inputId = ns("arg3"),
label = "Type of target variable",
choices = c(NA, "bina", "cont")),
numericInput(inputId = ns("arg4"),
label = "Minimum pct of observations per bin",
value = 0.05,
min = 0,
max = 1),
numericInput(inputId = ns("arg5"),
label = "Minimum avg target rate per bin",
value = 0.01,
min = 0,
max = 1),
numericInput(inputId = ns("arg6"),
label = "WoE threshold",
value = 0.1,
min = 0,
max = 1),
selectInput(inputId = ns("arg7"),
label = "Force trend",
choices = c(NA, "i", "d"))
)
}
#' Server side for monobin functions' inputs
#'@param id Namespace id.
#'@return No return value, server side call for user interface of the selected binning algorithm.
#'
#'@examples
#' if (interactive()) {
#' algo.ui(id = "monobin")
#' }
#'@export
algo.ui <- function(id) {
moduleServer(id, function(input, output, session) {
observeEvent(input$monobin.method, {
algo.select <- input$monobin.method
output$algo.args <- renderUI({
tagList(switch(algo.select,
"cum.bin" = cum.ui(id = id),
"iso.bin" = iso.ui(id = id),
"ndr.bin" = ndr.sts.ui(id = id),
"sts.bin" = ndr.sts.ui(id = id),
"pct.bin" = pct.ui(id = id),
"woe.bin" = woe.ui(id = id),
"mdt.bin" = mdt.ui(id = id)))
})
})
})
}
#' Check for categorical variables when importing the data
#'@param tbl Imported data frame.
#'@return Returns a character vector which describes variables type of imported data frame.
#'
#'@examples
#' if (interactive()) {
#' check.msg <- check.vars(tbl = rv$db)
#' }
#'@export
check.vars <- function(tbl) {
check <- !sapply(tbl, is.numeric)
check.col <- names(tbl)[check]
if (length(check.col) == 0) {
msg <- "All variables of numeric type."
} else {
cols <- paste(check.col, collapse = ", ")
msg <- paste0("Following variables identified as non-numeric:",
cols, ".")
}
return(msg)
}
#' Special cases - check input values
#'@param x Numeric vector of special case values.
#'@return Returns a list of three vectors: special case input(s) converted to numeric type,
#' number of special case input(s) that cannot be converted to
#' numeric type (including \code{NA}, \code{NaN} and \code{Inf}) and special case input(s)
#' that cannot be converted to numeric type.
#'
#'@examples
#' if (interactive()) {
#' sca.check.res <- sc.check(x = input$sc.all)
#' scr.check.res <- sc.check(x = input$sc.replace)
#' }
#'sc.check(x = "NA, NaN, Inf")
#'sc.check(x = "NA, abc")
#'sc.check(x = "NaN, abc")
#'sc.check(x = "Inf, abc")
#'sc.check(x = "9999999999, abc")
#'sc.check(x = "NA, NaN, Inf, 9999999999")
#'@export
sc.check <- function(x) {
if (""%in%x) {
return(list(NULL, 2, "Empty input field."))
}
if (is.na(x)) {
sc <- NA
} else {
sc <- trimws(strsplit(x, ",")[[1]])
}
if (length(sc) == 1) {
if (is.na(x) | is.infinite(x)) {
return(list(x, 0, x))
}
if (!sc%in%c("NA", "NaN", "Inf") & suppressWarnings(is.na(as.numeric(sc)))) {
return(list(NULL, 2, sc))
}
}
sc.num <- suppressWarnings(as.numeric(sc))
check.01 <- is.na(sc.num)
check.02 <- is.nan(sc.num)
check.99 <- check.01 & !check.02
check.val <- sc[check.99]
if (length(check.val) > 0) {
if (length(check.val) == 1) {
if (check.val != "NA") {
check.sum <- 2
} else {
check.sum <- 1
}
} else {
check.sum <- sum(check.99)
}
} else {
check.sum <- 0
}
return(list(sc.num, check.sum, check.val))
}
#' Special case imputation
#'@param tbl Data frame with risk factors ready for imputation.
#'@param rf Vector of risk factors to be imputed.
#'@param sc Numeric vector of special case values.
#'@param sc.replace Numeric vector of special case values that are selected for imputation.
#'@param imp.method Imputation method (mean or median).
#'@return Returns a list of three elements. The first element is a data frame with imputed values,
#' the second element is a vector of newly created risk factors (with imputed values) and the third one is
#' a data frame with information about possible imputation errors.
#'
#'@examples
#' if (interactive()) {
#' imp.res <- suppressWarnings(
#' sc.impute(tbl = rv$db,
#' rf = rf,
#' sc = sca.check.res[[1]],
#' sc.replace = scr.check.res[[1]],
#' imp.method = imp.method)
#' )
#' }
#'
#'@export
sc.impute <- function(tbl, rf, sc, sc.replace, imp.method) {
rfl <- length(rf)
rfn <- paste0(rf, "_sc_", imp.method)
rfn.f <- rfn
info.tbl <- vector("list", rfl)
info.msg <- "Imputed value cannot be calculated properly.
Selected risk factor is not processed.
Check the risk factor manually."
eval.exp <- paste0(imp.method, "(rf.imp[!rf.imp%in%sc])")
for (i in 1:rfl) {
rf.l <- rf[i]
rfn.l <- rfn[i]
rf.imp <- tbl[, rf.l]
rf.imp.val <- eval(parse(text = eval.exp))
if (rf.imp.val%in%c(NA, Inf, NaN)) {
info.tbl[[i]] <- data.frame(risk.factor = rf.l,
info = info.msg,
imputation.method = imp.method)
rfn.f <- rfn.f[!rfn.f%in%rfn.l]
next
} else {
rf.imp[rf.imp%in%sc.replace] <- rf.imp.val
if (rfn.l%in%names(tbl)) {
tbl[, rfn.l] <- rf.imp
} else {
tbl <- cbind.data.frame(tbl, rf.imp)
names(tbl)[ncol(tbl)] <- rfn.l
}
}
}
info.tbl <- bind_rows(info.tbl)
return(list(tbl, rf.imp = rfn.f, info = data.frame(info.tbl)))
}
#' Outliers imputation
#'@param tbl Data frame with risk factors ready for imputation.
#'@param rf Vector of risk factors to be imputed.
#'@param ub Upper bound percentiles.
#'@param lb Lower bound percentiles.
#'@param sc Numeric vector of special case values.
#'@return Returns a list of three elements. The first element is a data frame with imputed values,
#' the second element is a vector of newly created risk factors (with imputed values) and the third one is
#' a data frame with information about possible imputation errors.
#'
#'@examples
#' if (interactive()) {
#' imp.res <- suppressWarnings(
#' out.impute(tbl = rv$db,
#' rf = input$rf.out,
#' ub = upper.pct,
#' lb = lower.pct,
#' sc = sca.check.res[[1]])
#' )
#' }
#'
#'@export
out.impute <- function(tbl, rf, ub, lb, sc) {
rfl <- length(rf)
rfn <- paste0(rf, "_out_", ub, "_", lb)
rfn.f <- rfn
info.tbl <- vector("list", rfl)
info.msg <- "Imputed outlier value(s) cannot be calculated properly.
Selected risk factor is not processed.
Check the risk factor manually."
for (i in 1:rfl) {
rf.l <- rf[i]
rfn.l <- rfn[i]
rf.imp <- tbl[, rf.l]
complete.c <- rf.imp[!rf.imp%in%sc]
rf.imp.ub <- try(quantile(complete.c, ub), silent = TRUE)
rf.imp.lb <- try(quantile(complete.c, lb), silent = TRUE)
cond <- class(rf.imp.ub)%in%"try-error" | class(rf.imp.lb)%in%"try-error" |
rf.imp.ub%in%c(NA, Inf, NaN) | rf.imp.lb%in%c(NA, Inf, NaN)
if (cond) {
info.tbl[[i]] <- data.frame(risk.factor = rf.l,
info = info.msg,
pct.selected = paste0("upper bound = ", ub,
"; lower bound = ", lb))
rfn.f <- rfn.f[!rfn.f%in%rfn.l]
next
} else {
rf.imp[!rf.imp%in%sc & rf.imp > rf.imp.ub] <- rf.imp.ub
rf.imp[!rf.imp%in%sc & rf.imp < rf.imp.lb] <- rf.imp.lb
if (rfn.l%in%names(tbl)) {
tbl[, rfn.l] <- rf.imp
} else {
tbl <- cbind.data.frame(tbl, rf.imp)
names(tbl)[ncol(tbl)] <- rfn.l
}
}
}
info.tbl <- bind_rows(info.tbl)
return(list(tbl, rf.imp = rfn.f, info = data.frame(info.tbl)))
}
#' Descriptive statistics report
#'@param target Selected target.
#'@param rf Vector of a selected numeric risk factors.
#'@param sc Numeric vector of special case values.
#'@param sc.method Define how special cases will be treated, all together or in separate bins.
#'@param db Data frame of target and numeric risk factors.
#'@return Returns a data frame with descriptive statistics for the selected risk drivers.
#'
#'@examples
#' if (interactive()) {
#' srv$desc.stat <- withProgress(message = "Running descriptive statistics report",
#' value = 0, {
#' desc.report(target = "qual",
#' rf = rf,
#' sc = sc,
#' sc.method = sc.method,
#' db = isolate(rv$db))
#' })
#' }
#'
#'@export
desc.report <- function(target, rf, sc, sc.method, db) {
y <- db[, target]
rfl <- length(rf)
res <- vector("list", rfl)
for (i in 1:rfl) {
rf.n <- rf[i]
incProgress(1 / (rfl - i + 1), detail = paste("Processing risk factor:", rf.n))
x <- db[, rf.n]
desc.l <- suppressWarnings(
desc.stat(y = y,
x = x,
sc = sc,
sc.method = sc.method)
)
desc.l <- cbind.data.frame(risk.factor = rf.n, desc.l)
res[[i]] <- desc.l
}
res <- data.frame(bind_rows(res))
return(res)
}
#' Numeric arguments - monobin module
#'@param x Binning algorithm from monobin package.
#'@return Returns a list of two vectors: index and UI element label of numeric arguments of
#' the selected monobin function.
#'@examples
#' if (interactive()) {
#' inp.indx <- num.inputs(x = x)
#' }
#' num.inputs(x = "cum.bin")
#'
#'@export
num.inputs <- function(x) {
switch(x,
"cum.bin" = list(3, "Number of starting groups"),
"iso.bin" = list(c(4, 5), c("Minimum pct. of observations per bin",
"Minimum avg. target rate per bin")),
"ndr.bin" = list(c(4, 5, 6), c("Minimum pct. of observations per bin",
"Minimum avg. target rate per bin",
"p-value")),
"pct.bin" = list(3, "Number of starting groups"),
"sts.bin" = list(c(4, 5, 6), c("Minimum pct. of observations per bin",
"Minimum avg. target rate per bin",
"p-value")),
"woe.bin" = list(c(4, 5, 6), c("Minimum pct. of observations per bin",
"Minimum avg. target rate per bin",
"WoE threshold")),
"mdt.bin" = list(c(2, 5, 6), c("Number of splitting groups for each node",
"Minimum pct. of observations per bin",
"Minimum avg. target rate per bin")))
}
#' Check for numeric arguments - monobin module
#'@param x Binning algorithm from monobin package.
#'@param args.e Argument elements of the selected monobin function.
#'@return Returns a list of two vectors: logical if validation is successful and character vector
#' with validation message.
#'@examples
#' if (interactive()) {
#' num.inp <- mono.inputs.check(x = bin.algo, args.e = args.e)
#' }
#'
#'@export
mono.inputs.check <- function(x, args.e) {
inp.indx <- num.inputs(x = x)
num.args <- c(args.e[inp.indx[[1]]], recursive = TRUE)
check.01 <- any(is.na(num.args))
if (check.01) {
msg <- paste0("Numeric input(s) required for: ",
paste0(paste0("#", inp.indx[[2]], "#"), collapse = ", "), ".")
return(list(check.ok = FALSE, msg = msg))
}
if (x%in%c("cum.bin", "pct.bin")) {
if (num.args[1] < 2 | num.args[1] > 40) {
msg <- paste0("Input #Number of starting groups# has to be between 2 and 40.")
return(list(check.ok = FALSE, msg = msg))
}
}
if (x%in%c("iso.bin", "woe.bin")) {
if (any(num.args[1:2] < 0) | any(num.args[1:2] > 0.5)) {
msg <- paste0("Inputs: ",
paste0(paste0("#", inp.indx[[2]][1:2], "#"), collapse = ", "),
" have to be between 0 and 0.5")
return(list(check.ok = FALSE, msg = msg))
}
}
if (x%in%c("ndr.bin", "sts.bin")) {
if (any(num.args[1:2] < 0) | any(num.args[1:2] > 0.5)) {
msg <- paste0("Inputs: ",
paste0(paste0("#", inp.indx[[2]][1:2], "#"), collapse = ", "),
" have to be between 0 and 0.5")
return(list(check.ok = FALSE, msg = msg))
}
if (num.args[3] < 0.001 | num.args[3] > 0.2) {
msg <- paste0("Input #p-value# has to be between 0.001 and 0.2")
return(list(check.ok = FALSE, msg = msg))
}
}
if (x%in%c("mdt.bin")) {
if (num.args[1] < 2 | num.args[1] > 150) {
msg <- paste0("Input #Number of splitting groups for each node# has to be between 2 and 150.")
return(list(check.ok = FALSE, msg = msg))
}
if (any(num.args[2:3] < 0) | any(num.args[2:3] > 0.5)) {
msg <- paste0("Inputs: ",
paste0(paste0("#", inp.indx[[2]][2:3], "#"), collapse = ", "),
" have to be between 0 and 0.5")
return(list(check.ok = FALSE, msg = msg))
}
}
return(list(check.ok = TRUE, msg = "Inputs validated."))
}
#' Evaluation expression of the selected monobin function and its arguments
#'@param x Binning algorithm from monobin package.
#'@return Returns an evaluation expression of the selected monobin algorithm.
#'@examples
#' if (interactive()) {
#' expr.eval <- monobin.fun(x = algo)
#' }
#' monobin.fun(x = "ndr.bin")
#'
#'
#'@export
monobin.fun <- function(x) {
switch(x,
"cum.bin" = "cum.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], g = args.e[[3]],
y.type = args.e[[4]], force.trend = args.e[[5]])",
"iso.bin" = "iso.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], y.type = args.e[[3]],
min.pct.obs = args.e[[4]], min.avg.rate = args.e[[5]],
force.trend = args.e[[6]])",
"ndr.bin" = "ndr.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], y.type = args.e[[3]],
min.pct.obs = args.e[[4]], min.avg.rate = args.e[[5]],
p.val = args.e[[6]], force.trend = args.e[[7]])",
"pct.bin" = "pct.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], g = args.e[[3]],
y.type = args.e[[4]], woe.trend = args.e[[5]],
force.trend = args.e[[6]])",
"sts.bin" = "sts.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], y.type = args.e[[3]],
min.pct.obs = args.e[[4]], min.avg.rate = args.e[[5]],
p.val = args.e[[6]], force.trend = args.e[[7]])",
"woe.bin" = "woe.bin(y = target, x = rf.l, sc = sc,
sc.method = args.e[[2]], y.type = args.e[[3]],
min.pct.obs = args.e[[4]], min.avg.rate = args.e[[5]],
woe.gap = args.e[[6]], force.trend = args.e[[7]])",
"mdt.bin" = "mdt.bin(y = target, x = rf.l, sc = sc, g = args.e[[2]],
sc.method = args.e[[3]], y.type = args.e[[4]],
min.pct.obs = args.e[[5]], min.avg.rate = args.e[[6]],
force.trend = args.e[[7]])")
}
#' Run monobin algorithm for the selected inputs
#'@param algo Binning algorithm from monobin package.
#'@param target.n Selected target.
#'@param rf Vector of a selected numeric risk factors.
#'@param sc Numeric vector of special case values.
#'@param args.e Argument elements of the selected monobin function.
#'@param db Data frame of target and numeric risk factors.
#'@return Returns a list of two data frame. The first data frame contains the results of implemented
#' binning algorithm, while the second one contains transformed risk factors.
#'@examples
#' if (interactive()) {
#' tbls <- withProgress(message = "Running the binning algorithm",
#' value = 0, {
#' suppressWarnings(
#' monobin.run(algo = bin.algo,
#' target.n = isolate(input$trg.select),
#' rf = isolate(input$rf.select),
#' sc = scr.check.res[[1]],
#' args.e = args.e,
#' db = isolate(rv$db))
#' )})
#'
#' }
#'
#'@export
monobin.run <- function(algo, target.n, rf, sc, args.e, db) {
target <- db[, target.n]
expr.eval <- monobin.fun(x = algo)
rfl <- length(rf)
res <- vector("list", rfl)
res.trans <- vector("list", rfl)
for (i in 1:rfl) {
rf.n <- rf[i]
incProgress(1 / (rfl - i + 1), detail = paste("Processing risk factor:", rf.n))
rf.l <- db[, rf.n]
res.l <- eval(parse(text = expr.eval))
if (length(res.l) == 1) {
res.tbl <- res.l[1]
res.trans[[i]] <- NULL
} else {
res.tbl <- res.l[[1]]
res.trans[[i]] <- data.frame(x = res.l[[2]])
names(res.trans[[i]]) <- rf.n
}
res.tbl <- cbind.data.frame(risk.factor = rf.n, res.tbl)
res[[i]] <- res.tbl
}
res <- bind_rows(res)
res.trans <- bind_cols(res.trans)
if (nrow(res.trans) == 0) {
res.trans <- cbind.data.frame(target = target)
} else {
res.trans <- cbind.data.frame(target = target, res.trans)
}
names(res.trans)[1] <- target.n
return(list(res, res.trans))
}
Try the monobinShiny package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.