# R/S_class_.earl.R In DynTxRegime: Methods for Estimating Optimal Dynamic Treatment Regimes

#### Documented in .createearl

```# October 26, 2018

#' Class \code{.earl}
#'
#' Class \code{.earl} stores parameters required for EARL optimization step.
#'
#' @name internal-earl-class
#'
#' @keywords internal
#'
#' @slot x Matrix of covariates for kernel
#' @slot wp Vector of positive weights
#' @slot wn Vector of negative weights
#' @slot mu Matrix of outcome regression
#' @slot txVec Vector of treatment coded as -1/1
#' @slot invPi Vector of inverse propensity for treatment received
#' @slot response Vector of the response
#' @slot surrogate The Surrogate for the loss-function
#' @slot par Vector of regime parameters
#' @slot kernel The Kernel defining the decision function
setClass(Class = '.earl',
slots = c(wp = "vector",
wn = "vector"),
contains = c("LearningObject"))

##########
## METHODS
##########
#' Methods Available for Objects of Class \code{.earl}
#'
#' @name internal-earl-methods
#'
#' @keywords internal
NULL

#' @rdname internal-earl-methods
setMethod(f = ".subsetObject",
signature = c(methodObject = ".earl"),
definition = function(methodObject, subset) {

newLO <- .subsetObject(methodObject = as(object = methodObject,
Class = "LearningObject"),
subset = subset)

return( new(".earl",
"wp" = methodObject@wp[subset],
"wn" = methodObject@wn[subset],
newLO) )
})

#' @rdname internal-earl-methods
setMethod(f = ".objFn",
signature = c("par" = "numeric",
"methodObj" = ".earl",
"kernel" = "LinearKernel"),
definition = function(par,
methodObject,
kernel,
lambda, ...) {

bee <- par[ 1L]
vee <- par[-1L]

temp <- methodObject@x %*% vee

lb <- drop(x = vee %*% vee)*0.5*lambda
u <- drop(x = temp) + bee

res <- mean(x = methodObject@wp*
.phiFunc(surrogate = methodObject@surrogate,
u = u)) +
mean(x = methodObject@wn*
.phiFunc(surrogate = methodObject@surrogate,
u = -u)) + lb

if (is.nan(x = res)) res <- 1e10

return( res )

})

#' @rdname internal-earl-methods
setMethod(f = ".dobjFn",
signature = c("par" = "numeric",
"methodObj" = ".earl",
"kernel" = "LinearKernel"),
definition = function(par,
methodObject,
kernel,
lambda, ...) {

bee <- par[ 1L]
vee <- par[-1L]

u <- drop(x = methodObject@x %*% vee) + bee
du <- cbind(1.0, methodObject@x)

dlb <- c(0,lambda * vee)

res <- colMeans(x = methodObject@wp *
.dPhiFunc(surrogate = methodObject@surrogate,
u = u,
du = du)) +
colMeans(x = methodObject@wn *
.dPhiFunc(surrogate = methodObject@surrogate,
u = -u,
du = -du)) + dlb

if (any(is.nan(x = res))) res[] <- 1e10

return( drop(x = res) )

})

#' @rdname internal-earl-methods
setMethod(f = ".objFn",
signature = c("par" = "numeric",
"methodObj" = ".earl",
"kernel" = "Kernel"),
definition = function(par,
methodObject,
kernel,
lambda, ...) {

bee <- par[ 1L]
vee <- par[-1L]

temp <- methodObject@x %*% vee

lb <- drop(x = vee %*% temp)*0.5*lambda
u <- drop(x = temp) + bee

res <- mean(x = methodObject@wp *
.phiFunc(surrogate = methodObject@surrogate,
u = u)) +
mean(x = methodObject@wn *
.phiFunc(surrogate = methodObject@surrogate,
u = -u)) + lb

if (is.nan(x = res)) res <- 1e10

return( res )

})

#' @rdname internal-earl-methods
setMethod(f = ".dobjFn",
signature = c("par" = "numeric",
"methodObj" = ".earl",
"kernel" = "Kernel"),
definition = function(par,
methodObject,
kernel,
lambda, ...) {

bee <- par[ 1L]
vee <- par[-1L]

temp <- drop(x = methodObject@x %*% vee)

u <- temp + bee
du <- cbind(1.0, methodObject@x)
dlb <- c(0.0,lambda * temp)

res <- colMeans(x = methodObject@wp *
.dPhiFunc(surrogate = methodObject@surrogate,
u = u,
du = du)) +
colMeans(x = methodObject@wn *
.dPhiFunc(surrogate = methodObject@surrogate,
u = -u,
du = -du)) + dlb

if (any(is.nan(x = res))) res[] <- 1e10
return( drop(res) )

})

#' \code{.objFn} not allowed for EARL with multiple radial kernels
#'
#' @rdname internal-earl-methods
setMethod(f = ".objFn",
signature = c("par" = "numeric",
"methodObject" = ".earl",
"kernel" = "MultiRadialKernel"),
definition = function(par,
methodObject,
kernel,
lambda, ...) { stop("not allowed") })

#' \code{.dobjFn} not allowed for EARL with multiple radial kernels
#'
#' @rdname internal-earl-methods
setMethod(f = ".dobjFn",
signature = c("par" = "numeric",
"methodObject" = ".earl",
"kernel" = "MultiRadialKernel"),
definition = function(par,
methodObject,
kernel,
lambda, ...) { stop("not allowed") })

#' @rdname internal-earl-methods
setMethod(f = ".valueFunc",
signature = c("methodObject" = ".earl"),
definition = function(methodObject, optTx, ...) {

posOpt <- optTx > 0.5
posTx <- methodObject@txVec > 0.5

ind <- {!posTx & !posOpt} | {posTx & posOpt}

mec <- methodObject@mu[,1L]
mec[posOpt] <- methodObject@mu[posOpt, 2L]

val <- {methodObject@response - mec} * ind * methodObject@invPi + mec
badVal <- is.infinite(x = val) | is.na(x = val) | is.nan(x = val)

val[badVal] <- 0.0

value <- mean(x = val)

return( value )
})

#' Create method object for EARL
#'
#' @param kernel Kernel object
#' @param txVec Vector of tx coded as -1/1
#' @param response Vector of responses
#' @param prWgt Vector of propensity for tx received
#' @param surrogate Surrogate object indicating surrogate loss-function
#' @param guess Vector of estimated regime parameters
#' @param mu Matrix of outcome regression (zero/ignored)
#'
#' @return An .earl object
#'
#' @name createearl
#'
#' @keywords internal
.createearl <- function(kernel,
txVec,
response,
prWgt,
surrogate,
guess = NULL,
mu, ...) {

newLO <- .createLearningObject(kernel = kernel,
surrogate = surrogate,
guess = guess,
mu = mu,
txVec = txVec,
prWgt = prWgt,
response = response)

wNeg <- {txVec < 0.0} * {response - mu[,1L]} / prWgt + mu[,1L]
wPos <- {txVec > 0.0} * {response - mu[,2L]} / prWgt + mu[,2L]

wp <-  wPos * {wPos > 0.0} - wNeg * {wNeg < 0.0}
wn <- -wPos * {wPos < 0.0} + wNeg * {wNeg > 0.0}

return( new(".earl",
"wp" = wp,
"wn" = wn,
newLO) )

}
```

## Try the DynTxRegime package in your browser

Any scripts or data that you put into this service are public.

DynTxRegime documentation built on Nov. 10, 2020, 1:08 a.m.