R/Arms.R

In TrialSimulator: Clinical Trial Simulator

#' Class of Arm
#' @description
#' Create a class of arm.
#'
#' Public methods in this R6 class are used in developing
#' this package. Thus, we have to export the whole R6 class which exposures all
#' public methods. However, only the public methods in the list below are
#' useful to end users.
#'
#' \itemize{
#' \item \code{$add_endpoints()}
#' \item \code{$print()}
#' }
#'
#' @docType class
#'
#' @importFrom rlang expr_text
#'
#' @examples
#' # Instead of using Arms$new(), please use arm(), a user-friendly
#' # wrapper. See examples in ?arm
#'
#' @export
Arms <- R6::R6Class(
  'Arms',

  public = list(
    #' @description
    #' initialize an arm
    #' @param name name of arm, which is the arm's label in generated data
    #' @param ... subset condition that is compatible with \code{dplyr::filter}.
    #' This can be used to specify inclusion criteria of an arm.
    #' By default it is not specified, i.e. all data generated by the generator
    #' will be used as trial data. More than one conditions can be
    #' specified in \code{...}.
    initialize = function(name, ...){
      stopifnot(is.character(name))

      private$name <- name
      private$endpoints <- list()
      private$inclusion_filters <- enquos(...)
    },

    #' @description
    #' add one or multiple endpoints to the arm.
    #' @param ... one or more objects returned from \code{endpoint()}.
    #'
    #' @examples
    #'
    #' a <- arm(name = 'trt')
    #' x <- endpoint(name = 'x', type = 'tte',
    #'               generator = rexp) # median = log(2)/1 = 0.7
    #' y <- endpoint(name = 'y', type = 'non-tte', readout = c(y = 0),
    #'               generator = rnorm, sd = 1.4, mean = 0.7)
    #'
    #' a$add_endpoints(y, x)
    #'
    #' ## run it in console to see the summary report
    #' a
    #'
    #' print(a) # use the print method
    #'
    add_endpoints = function(...){
      endpoint_list <- list(...)

      for(ep in endpoint_list){
        stopifnot(inherits(ep, 'Endpoints'))
        if(ep$get_uid() %in% names(private$endpoints)){
          stop('Endpoint <', ep$get_uid(), '> is already in the arm <',
               self$get_name(), '>. ')
        }
        private$endpoints[[ep$get_uid()]] <- ep
      }
    },

    #' @description
    #' return name of arm.
    get_name = function(){
      private$name
    },

    #' @description
    #' return number of endpoints in the arm.
    get_number_endpoints = function(){

      if(length(private$endpoints) == 0){
        return(0)
      }

      sapply(
        private$endpoints,
        function(ep){
          length(ep$get_name())
        }
      ) %>%
        sum()
    },

    #' @description
    #' check if the arm has any endpoint. Return \code{TRUE} or \code{FALSE}.
    has_endpoint = function(){
      self$get_number_endpoints() > 0
    },

    #' @description
    #' return a list of endpoints in the arm.
    get_endpoints = function(){
      private$endpoints
    },

    #' @description
    #' return name of endpoints registered to the arm.
    get_endpoints_name = function(){
      lapply(
        self$get_endpoints(),
        function(ep){
          ep$get_name()
        }
      ) %>%
        unlist() %>%
        unname()
    },

    #' @description
    #' generate arm data.
    #'
    #' @param n_patients_in_arm integer.
    #' Number of patients randomized to the arm.
    generate_data = function(n_patients_in_arm){

      arm_data <- NULL
      while(is.null(arm_data) || nrow(arm_data) < n_patients_in_arm){
        dat <- NULL
        for(ep in self$get_endpoints()){
          if(is.null(dat)){
            dat <- ep$get_generator()(n_patients_in_arm)
          }else{
            dat <- cbind(dat, ep$get_generator()(n_patients_in_arm))
          }
        }

        filter_str <- paste0("(", sapply(private$inclusion_filters, expr_text), ")", collapse = " & ")

        dat <- if(length(private$inclusion_filters) == 0){
          dat
        }else{
          tryCatch({
            dat %>% dplyr::filter(!!!private$inclusion_filters)
          }, error = function(e){
            stop(
              'Error in filtering data for arm <', self$get_name(), '>: \n',
              'Inclusion criteria: \n', filter_str, '\n',
              'Error message: \n', e$message
            )
          })
        }

        if(nrow(dat) == 0){
          stop('No data meets inclusion criteria of arm <',
               self$get_name(), '>: \n',
               filter_text
          )
        }

        arm_data <- rbind(arm_data, dat)
      }

      head(arm_data, n_patients_in_arm)
    },

    #' @description
    #' print an arm.
    #'
    #' @param categorical_vars character vector of categorical variables.
    #' This can be used to specify variables with limited distinct (numeric)
    #' values as categorical variables in summary report.
    print = function(categorical_vars = NULL){
      white_text_blue_bg <- "" ## "\033[37;44m"
      reset <- "" ## "\033[0m"  # Reset to default color
      logo <- '\u2695\u2695' ## stringi::stri_escape_unicode('⚕')

      # cat(white_text_blue_bg, logo, 'Arm Name: ', self$get_name(), reset, '\n')
      # cat(white_text_blue_bg, logo, '# of Endpoints: ', self$get_number_endpoints(), reset, '\n')
      # cat(white_text_blue_bg, logo, 'Registered Endpoints: ',
      #     paste0(self$get_endpoints_name(), collapse = ', '), reset, '\n')

      title <- paste0('Arm Name: ', self$get_name())
      sub_title <- paste0('Endpoints (',
                          self$get_number_endpoints(), '):',
                          paste0(self$get_endpoints_name(), collapse = ', '))

      dat <- self$generate_data(n_patients_in_arm = 1e4)
      vars <- self$get_endpoints_name()
      event_vars <- intersect(paste0(vars, '_event'), names(dat))
      tte_vars <- gsub('_event$', '', event_vars)
      exclude_vars <- grep('_readout$', names(dat), value = TRUE)


      if(requireNamespace("knitr", quietly = TRUE) &&
         isTRUE(getOption('knitr.in.progress'))) {
        summary_html <- summarizeDataFrame(dat, exclude_vars = exclude_vars,
                                           tte_vars = tte_vars, event_vars = event_vars,
                                           categorical_vars = categorical_vars,
                                           title = title, sub_title = sub_title)

        temp_file <- tempfile(fileext = ".html")
        writeLines(summary_html, temp_file, useBytes = TRUE)

        if(requireNamespace("htmltools", quietly = TRUE)) {
          iframe_html <- htmltools::tags$iframe(
            src = paste0("data:text/html;charset=utf-8;base64,", base64enc::base64encode(temp_file)),
            width = "100%",
            height = "500px",
            style = "border: 1px solid #ccc; border-radius: 4px;"
          )
          cat(as.character(iframe_html))
        } else {
          file_content <- paste(readLines(temp_file), collapse = "\n")
          file_b64 <- base64enc::base64encode(charToRaw(file_content))
          cat('<iframe src="data:text/html;charset=utf-8;base64,', file_b64,
              '" width="100%" height="500px" style="border: 1px solid #ccc;"></iframe>')
        }
      } else {
        summarizeDataFrame(dat, exclude_vars = exclude_vars,
                           tte_vars = tte_vars, event_vars = event_vars,
                           categorical_vars = categorical_vars,
                           title = title, sub_title = sub_title)
      }

      invisible(self)

    }
  ),

  private = list(
    name = NULL,
    inclusion_filters = NULL,
    endpoints = list()
  )
)