#' @include bin.class.R
#' @export
setAs("Classing", "list", def = function(from) from@classing)
#' @export
`dropped<-` <- function(x, value) set.meta.attr(x, value, "drop")
#' @export
dropped <- function(x) get.meta.attr(x, "drop")
#' @export
`penalty<-` <- function(x, value) set.meta.attr(x, value, "penalty")
#' @export
`penalty` <- function(x, value) get.meta.attr(x, "penalty")
#' @export
`inmodel<-` <- function(x, value) set.meta.attr(x, value, "inmodel")
#' @export
inmodel <- function(x) get.meta.attr(x, "inmodel")
#' @export
`new.vars<-` <- function(x, value) set.meta.attr(x, value, "new")
#' @export
new.vars <- function(x) get.meta.attr(x, "new")
#' @export
`steptwo<-` <- function(x, value) set.meta.attr(x, value, "steptwo")
#' @export
steptwo <- function(x) get.meta.attr(x, "steptwo")
#' @export
`approved<-` <- function(x, value) set.meta.attr(x, value, "approved")
#' @export
approved <- function(x) get.meta.attr(x, "approved")
#' @export
setMethod("names", "Classing", function(x) {
sapply(as(x, "list"), slot, "name")
})
setMethod("set.meta.attr", "Bin",
function(x, value, .slot) {
slot(x, .slot) <- value
Update(x)
})
setMethod("set.meta.attr", "Classing",
function(x, value, .slot) {
for (i in seq_along(x)) x[[i]] <- callGeneric(x[[i]], value[i], .slot)
initialize(x)
})
setMethod("set.meta.attr", "Scorecard",
function(x, value, .slot) {
initialize(x, classing=callGeneric(x@classing, value=value, .slot=.slot))
})
setMethod("set.meta.attr", "ANY",
function(x, value, .slot) {
cat(sprintf("Method not implemented for class: %s", class(x)))
})
## TODO: Implement some day...
## segmented methods
# setMethod("set.meta.attr", "Segmented-Classing",
# function(x, value, .slot) {
# browser()
# classings <- lapply(x@classings, set.meta.attr, value, .slot)
# initialize(x, classings=classings)
# })
# setMethod("set.meta.attr", "Segmented-Scorecard",
# function(x, value, .slot) {
# browser()
# #scorecards <- lapply(x@scorecards, set.meta.attr, value, .slot)
# scorecards <- mapply(set.meta.attr, x@scorecards, value, MoreArgs = list(.slot=.slot))
# initialize(x, scorecards=scorecards)
# })
setMethod("get.meta.attr", "Bin", function(x, .slot) slot(x, .slot))
setMethod("get.meta.attr", "Classing", function(x, .slot) {
n <- names(x)
out <- sapply(as(x, "list"), slot, .slot, USE.NAMES = FALSE)
names(out) <- n
out
})
setMethod("get.meta.attr", "Scorecard", function(x, .slot) {
callGeneric(x@classing, .slot=.slot)
})
setMethod("get.meta.attr", "Segmented-Classing", function(x, .slot) {
lapply(x@classings, get.meta.attr, .slot)
})
setMethod("get.meta.attr", "Segmented-Scorecard", function(x, .slot) {
lapply(x@scorecards, get.meta.attr, .slot)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.