R/name_helpers.R

In stephematician/trialcostR: Trial Cost-Effectiveness in R

# 
standard_covariate_names <- function(trial) {
    setNames(
        c(paste0('x',
                 1:length(all.vars(trial@participant))),
          paste0('y',
                 1:length(all.vars(trial@outcome)))),
        c(all.vars(trial@participant),
          all.vars(trial@outcome))
    )

}

valid_formula <- function(expr, n, m, rx_format) {

    all(all.names(expr) %in% c('~', '*', '+', all.vars(expr))) &
    length(all.names(expr)) == n &
    grepl(rx_format, paste0(all.names(expr), collapse='')) &    
    all(all.vars(expr)[m] %in% labels(terms(expr)))

}

# Check formula is in simple form: `~ a + b + c`
valid_linear_formula <- function(expr) {

    if(length(expr) == 0) {
        FALSE
    } else {
        valid_formula(expr,
                      ifelse(length(all.vars(expr)) == 0,
                             1,
                             2 * length(all.vars(expr))),
                      -(length(all.vars(expr))+1), 
                      '^~\\+*[^\\+]*$')
    }

}


# Check formula is in the form: `time*regime*relative ~ a + b + c`
# - The time variable is the time interval data, t_j
# - The regime is the name of the variable which indicates the health state
#   regime that this interval applies to
# - The relative variable is a boolean value which is either
#     - 0, indicates that the interval is an 'initial' stage which ends at time
#       t = t_j
#     - 1, inidcates that the interval is a 'final' stage, where the state is
#       starts at t = T - t_j.
valid_interval_spec_formula <- function(expr) {

    if(length(expr) == 0) {
        FALSE
    } else {
        valid_formula(expr,
                      5 + max(1, 2 * length(labels(terms(expr)))),
                      -c(1,2,3),
                      '^~\\*\\*[^\\+]+\\+*[^\\+]*$')
    }

}

# Check formula is in the form: `response ~ a + b + c`
valid_response_formula <- function(expr) {

    if(length(expr) == 0) {
        FALSE
    } else {
        valid_formula(expr,
                      1 + max(1, 2 * length(labels(terms(expr)))),
                      -1,
                      '^~[^\\+]+\\+*[^\\+]*$')
    }

}

# Check variables are available in the data.frame
df_has_linear_terms <- function(df, expr) {

    all(labels(terms(expr)) %in% names(df))

}

# Check variables are available in the data.frame
df_has_all_terms <- function(df, expr) {

    all(all.vars(expr) %in% names(df))

}