Nothing
# October 26, 2018
#' Class \code{Kernel}
#'
#' Class \code{Kernel} holds information regarding the decision function kernel
#'
#' @name Kernel-class
#'
#' @slot model An formula. Defines the covariates of the kernel.
#' @slot X A matrix. The covariates of the kernel
#' @slot kparam ANY. The kernel parameter
#'
#' @keywords internal
setClass(Class = "Kernel",
slots = c("model" = "formula",
"X" = "matrix",
"kparam" = "ANY"),
prototype = prototype(model = ~1, X = matrix(), kparam = NULL) )
#' @rdname DynTxRegime-internal-api
#' @importFrom stats terms model.matrix update.formula
setMethod(f = "initialize",
signature = c(.Object = "Kernel"),
definition = function(.Object, data, model, kparam, ...) {
if (!missing(model)) {
.Object@model <- model
if (attr(stats::terms(.Object@model),"intercept") == 1L) {
.Object@model <- stats::update.formula(.Object@model, ~.-1)
}
}
if (!missing(data)) {
.Object@X <- tryCatch(expr = stats::model.matrix(object = .Object@model,
data = data),
error = function(e) {
print(x = e$message)
stop("unable to identify needed variables in data")
return(e)
})
attr(.Object@X, "assign") <- NULL
if (nrow(x = data) != nrow(x = .Object@X)) stop("missing data")
}
if (!missing(kparam)) .Object@kparam <- kparam
return( .Object )
})
##########
## GENERICS
##########
#' @rdname DynTxRegime-internal-api
setGeneric(name = ".getKernelX",
def = function(data, object, ...) {
standardGeneric(f = ".getKernelX")
})
#' @rdname DynTxRegime-internal-api
setGeneric(name = ".kernel",
def = function(object, x1, x2, ...) {
standardGeneric(f = ".kernel")
})
#' @rdname DynTxRegime-internal-api
setGeneric(name = ".kernelNumPars",
def = function(object, ...) {
standardGeneric(f = ".kernelNumPars")
})
##########
## METHODS
##########
#' Methods Available for Objects of Class \code{Kernel}
#'
#' @name Kernel-methods
#'
#' @keywords internal
NULL
#' \code{.getKernelX}
#' retrieves the covariates matrix of the kernel.
#'
#' @rdname Kernel-methods
#' @importFrom stats model.matrix
setMethod(f = ".getKernelX",
signature = c(data = "data.frame",
object = "Kernel"),
definition = function(data, object) {
x <- tryCatch(expr = stats::model.matrix(object = object@model,
data = data),
error = function(e) {
print(x = e$message)
stop("unable to identify needed variables in newdata")
return( e )
})
attr(x, "assign") <- NULL
if (nrow(x = data) != nrow(x = x)) stop("missing data")
return( x )
})
#' \code{.kernelNumPars}
#' retrieves the number of covariates of the kernel.
#'
#' @rdname Kernel-methods
setMethod(f = ".kernelNumPars",
signature = c(object = "Kernel"),
definition = function(object, ...) {
return( nrow(x = object@X) + 1L )
})
#' \code{.kernel}
#' calculates the kernel
#'
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "missing",
x2 = "missing"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object, x1 = object@X, x2 = object@X) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "data.frame",
x2 = "data.frame"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object,
x1 = .getKernelX(data = x1, object = object),
x2 = .getKernelX(data = x2, object = object), ...) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "vector",
x2 = "vector"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object,
x1 = matrix(data = x1, ncol = 1L),
x2 = matrix(data = x2, ncol = 1L), ...) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "vector",
x2 = "data.frame"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object,
x1 = matrix(data = x1, ncol = 1L),
x2 = .getKernelX(data = x2, object = object), ...) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "data.frame",
x2 = "vector"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object,
x1 = .getKernelX(data = x1, object = object),
x2 = matrix(data = x2, ncol = 1L), ...) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "matrix",
x2 = "data.frame"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object,
x1 = x1,
x2 = .getKernelX(data = x2, object = object), ...) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "data.frame",
x2 = "matrix"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object,
x1 = .getKernelX(data = x1, object = object),
x2 = x2, ...) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "vector",
x2 = "matrix"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object,
x1 = matrix(data = x1, ncol = 1L),
x2 = x2, ...) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "matrix",
x2 = "vector"),
definition = function(object, x1, x2, ...) {
return( .kernel(object = object,
x1 = x1,
x2 = matrix(data = x2, ncol = 1L), ...) )
})
#' @rdname Kernel-methods
setMethod(f = ".kernel",
signature = c(object = "Kernel",
x1 = "matrix",
x2 = "matrix"),
definition = function(object, x1, x2, ...) { stop("not allowed") })
#' \code{print}
#' prints kernel model.
#'
#' @rdname Kernel-methods
setMethod(f = "print",
signature = c(x = "Kernel"),
definition = function(x, ...) {
cat("kernel model = ")
print(x = x@model)
})
#' \code{show}
#' displays kernel model.
#'
#' @rdname Kernel-methods
setMethod(f = "show",
signature = c(object = "Kernel"),
definition = function(object) {
cat("kernel model = ")
show(object = object@model)
})
#' \code{summary}
#' returns a list containing the kernel model.
#'
#' @rdname Kernel-methods
setMethod(f = "summary",
signature = c(object = "Kernel"),
definition = function(object, ...) {
return( list("kernelModel" = object@model) )
})
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.