R/Trial.R

In stephematician/trialcostR: Trial Cost-Effectiveness in R

#' @importFrom stats terms
#' @import methods
#' @include name_helpers.R
NULL

#' Trial data
#'
#' An S4 class for trial data.
#'
#'
#' @slot df a tbl_df of trial participant and outcome data
#' @slot participant a formula for variables describing participant
#' @slot outcome a formula for variables describing outcomes
#' @slot followup a numeric vector of follow-up times of participants
#' @slot discount a numeric (scalar) value of the lifeyear discount rate
#'
#' @name Trial-class
#' @rdname Trial-class
#' @exportClass Trial
setClass('Trial',
    slots = list(df = 'tbl_df',
                 participant = 'formula',
                 outcome = 'formula',
                 followup = 'numeric',
                 discount = 'numeric'),
    validity = function(.Object) {
        msg <- character(0)

        if(length(.Object@discount) != 1)
            msg <- c(msg,
                     'Discount rate must be scalar value.')

        if(length(.Object@followup) != nrow(.Object@df))
            msg <- c(msg,
                     'Lengths of followup and trial data must be equal.')

        if(!valid_linear_formula(.Object@participant))
            msg <- c(msg,
                     'Invalid data-specification expression for participant.')

        if(!df_has_linear_terms(.Object@df, .Object@participant))
            msg <- c(msg,
                     paste('Trial data does not contain required variables',
                           'given the data specification for participants.'))

        if(!valid_linear_formula(.Object@outcome))
            msg <- c(msg,
                     'Invalid data-specification expression for outcome.')

        if(!df_has_linear_terms(.Object@df, .Object@outcome))
            msg <- c(msg,
                     paste('Trial data does not contain required variables',
                           'given the data specification for outcomes.'))

        if(any(labels(terms(.Object@outcome)) %in% 
                   labels(terms(.Object@participant))))
            msg <- c(msg,
                     paste('Conflicting variables in participant and outcome',
                           'formula.'))

        if (length(msg) == 0)
            TRUE
        else
            msg
    }
)

#' Create a Trial
#'
#' TODO documentation
#'
#' @param df a tbl_df of the trial data (long format)
#' @param participant a formula for the variables describing participants
#' @param outcome a formula for the variables describing outcomes
#' @param followup expression for follow-up in data.frame (NSE)
#' @param discount numeric (scalar) value of lifeyear discount rate
#'
#' @name Trial
#' @rdname Trial-class
#' @export
Trial <- function(df,
                  participant,
                  outcome,
                  followup,
                  discount=0) {
    new('Trial',
        df=select_(tbl_df(df),
                   .dots=as.list(
                             unlist(
                                 lapply(c(terms(participant),
                                          terms(outcome)),
                                        labels)
                             )
                         )),
        participant=participant,
        outcome=outcome,
        followup=eval(substitute(followup), df, parent.frame()),
        discount=discount)
}

#' Life-years from trial data
#' @param trial a trial object
#' @name lifeyear
#' @rdname lifeyear-methods
#' @exportMethod lifeyear
setGeneric('lifeyear', 
    function(trial) {
        standardGeneric('lifeyear')
    }
)

#' Discounted life-years from trial data
#' @param trial a trial object
#' @name dlifeyear
#' @rdname dlifeyear-methods
#' @exportMethod dlifeyear
setGeneric('dlifeyear', 
    function(trial) {
        standardGeneric('dlifeyear')
    }
)

#' Outcomes from trial data
#' @param trial a trial object
#' @name outcomes
#' @rdname outcomes-methods
#' @exportMethod outcomes
setGeneric('outcomes',
    function(trial) {
        standardGeneric('outcomes')
    }
)

#' Participant trial data
#' @param trial a trial object
#' @name participants
#' @rdname participants-methods
#' @exportMethod participants
setGeneric('participants', 
    function(trial) {
        standardGeneric('participants')
    }
)

#' @rdname lifeyear-methods
#' @aliases lifeyear,Trial-method
setMethod('lifeyear',
    c(trial = 'Trial'),
    function(trial) {
        trial@followup
    }
)

#' @rdname dlifeyear-methods
#' @aliases dlifeyear,Trial-method
setMethod('dlifeyear',
    c(trial = 'Trial'),
    function(trial) {
        if (trial@discount != 0) {
            (1 - exp(-trial@discount*trial@followup)) / trial@discount
        } else {
            trial@followup
        }
    }
)

#' @rdname outcomes-methods
#' @aliases outcomes,Trial-method
#' @importFrom stats model.frame
setMethod('outcomes',
    c(trial = 'Trial'),
    function(trial) {
        model.frame(trial@outcome, data=trial@df)
    }
)

#' @rdname participants-methods
#' @aliases participants,Trial-method
#' @importFrom stats model.frame
setMethod('participants',
    c(trial = 'Trial'),
    function(trial) {
        model.frame(trial@participant, data=trial@df)
    }
)