Creating custom source extension

If you want to use shinyCohortBuilder with a custom source type, a set of methods needs to be defined.

Currently there exists one official extension cohortBuilder.db package that allows you to use shinyCohortBuilder (and cohortBuilder) with database connections.

The goal of this document is to explain how to create custom extensions to shinyCohortBuilder.

In general to create the custom layer you need to create an R package where:

  1. The custom Source extension for cohortBuilder methods is implemented (see. vignettes("custom-extensions", package = "cohortBuilder")).
  2. A set of integration S3 methods for shinyCohortBuilder are implemented.
  3. Extra filters (added in the extension) GUI layers are implemented (see custom GUI filters).

If you have cohortBuilder integration ready for the selected source type (a new package named cohortBuilder.<type>), the next step is to add shinyCohortBuilder integration.

Below we describe all the required and optional methods you need to define within the created package.

  1. .render_filters - method used to define structure for filters rendering in a selected step

Required parameters:

Details:

Examples:

.render_filters.default <- function(source, cohort, step_id, ns, ...) {
  step <- cohort$get_step(step_id)
  shiny::tagList(
    shiny::htmlOutput(ns(paste0(step_id, "-stats")), class = "scb_data_stats"),
    step$filters %>%
      purrr::map(~ .render_filter(.x, step_id, cohort, ns = ns)) %>%
      shiny::div(class = "cb_filters", `data-step_id` = step_id)
  )
}
.render_filters.tblist <- function(source, cohort, step_id, ns, ...) {
  step <- cohort$get_step(step_id)

  group_filters(cohort$get_source(), step$filters) %>%
    purrr::imap(~ dataset_filters(.x, .y, step_id, cohort, ns = ns)) %>%
    shiny::div(class = "cb_filters", `data-step_id` = step_id)
}

In this example we group all the defined filters by related datasets from source (group_filters), and attach a separate statistics placeholder for each dataset (dataset_filters).

render_filters.db <- function(source, cohort, step_id, ns) {
  step <- cohort$get_step(step_id)

  group_filters_db(cohort$get_source(), step$filters) %>%
    purrr::imap(~ dataset_filters_db(.x, .y, step_id, cohort, ns = ns)) %>%
    div(class = "cb_filters", `data-step_id` = step_id)
}
  1. .update_data_stats - logic for updating data statistics

Required parameters:

Details:

Examples:

.update_data_stats.default <- function(source, step_id, cohort, session, ...) {
  ns <- session$ns
  stats <- cohort$attributes$stats

  session$output[[paste0(step_id, "-stats")]] <- shiny::renderUI({
    previous <- cohort$get_cache(step_id, state = "pre")$n_rows
    if (!previous > 0) {
      return("No data selected in previous step.")
    }
    current <- cohort$get_cache(step_id, state = "post")$n_rows
    .pre_post_stats(current, previous, percent = TRUE, stats = stats)
  })
}
.update_data_stats.tblist <- function(source, step_id, cohort, session, ...) {
  stats <- cohort$attributes$stats
  step <- cohort$get_step(step_id)

  dataset_names <- names(cohort$get_source()$attributes$datasets)
  data_filters <- purrr::map_chr(step$filters, get_filter_dataset)
  dataset_names <- intersect(dataset_names, data_filters)

  dataset_names %>% purrr::walk(
    ~ .sendOutput(
      paste0(step_id, "-stats_", .x),
      shiny::renderUI({
        previous <- cohort$get_cache(step_id, state = "pre")[[.x]]$n_rows
        if (!previous > 0) {
          return("No data selected in previous step.")
        }
        current <- cohort$get_cache(step_id, state = "post")[[.x]]$n_rows
        .pre_post_stats(current, previous, percent = TRUE, stats = stats)
      }),
      session
    )
  )
}
update_data_stats.db <- function(source, step_id, cohort, session) {
  stats <- cohort$attributes$stats

  dataset_names <- source$attributes$tables
  dataset_names %>% purrr::walk(
    ~ shinyCohortBuilder::sendOutput(
      paste0(step_id, "-stats_", .x),
      shiny::renderUI({
        previous <- cohort$get_cache(step_id, state = "pre")[[.x]]$n_rows
        if (!previous > 0) {
          return("No data selected in previous step.")
        }
        current <- cohort$get_cache(step_id, state = "post")[[.x]]$n_rows
        shinyCohortBuilder::pre_post_stats(current, previous, percent = TRUE, stats = stats)
      })
    )
  )
}
  1. autofilter (optional) - automatically generate filters configuration based on Source data

Required parameters:

Details:

Examples:

autofilter.tblist <- function(source, attach_as = c("step", "meta"), ...) {
  attach_as <- rlang::arg_match(attach_as)
  step_rule <- source$dtconn %>%
    purrr::imap(~filter_rules(.x, .y)) %>%
    unlist(recursive = FALSE) %>%
    purrr::map(~do.call(cohortBuilder::filter, .)) %>%
    unname()

  if (identical(attach_as, "meta")) {
    source$attributes$available_filters <- step_rule
  } else {
    source %>%
      cohortBuilder::add_step(do.call(cohortBuilder::step, step_rule))
  }

  return(source)
}
  1. .available_filters_choices - define choices for new step configuration panel

Required parameters:

Details:

Examples:

.available_filters_choices.tblist <- function(source, cohort, ...) {

  available_filters <- cohort$attributes$available_filters

  choices <- purrr::map(available_filters, function(x) {
    tibble::tibble(
      name = as.character(
        shiny::div(
          `data-tooltip-z-index` = 9999,
          `data-tooltip` = x$get_params("description"),
          `data-tooltip-position` = "top right",
          `data-tooltip-allow-html` = "true",
          x$name
        )
      ),
      id = x$id,
      dataset = x$get_params("dataset")
    )
  }) %>% dplyr::bind_rows()

  shinyWidgets::prepare_choices(choices, name, id, dataset)
}
  1. .step_attrition - define how step attrition plot should be rendered

Required parameters:

Details:

Examples:

.step_attrition.default <- function(source, id, cohort, session, ...) {
  ns <- session$ns

  list(
    render = shiny::renderPlot({
      cohort$show_attrition()
    }),
    output = shiny::plotOutput(id)
  )
}
.step_attrition.tblist <- function(source, id, cohort, session, ...) {
  ns <- session$ns
  choices <- names(source$attributes$datasets)

  list(
    render = shiny::renderPlot({
      cohort$show_attrition(dataset = session$input$attrition_input)
    }),
    output = shiny::tagList(
      shiny::selectInput(ns("attrition_input"), "Choose dataset", choices),
      shiny::plotOutput(id)
    )
  )
}
  1. .custom_attrition - (optional) a custom method used for your own version of attrition plot

The parameters and output structure is the same as for .step_attrition. The main difference is that you should put your custom logic for generating attrition (i.e. using a specific package meant for this).

When the method is defined, the attrition will be printed inside an extra tab of attrition modal.