Add support for filtering data with comma (or simillar) separated values (add `discrete_sep` filtering method)

[maciekbanas]

Suppose we have a data.frame with column tags where we store in every cell a string with comma-separated tags, such as: R package, R, RWD. I would like to have filter for every of this tag, so when I "check" R package, cohortBuilder filters for me all rows with tags that contain R package in the string.

We use in our dashboard a workaround, but it would be great to have such method directly in cohortBuilder (with optional parameter to control the separator - either comma or semi-colon e.g.):

#' @export
#' @importFrom cohortBuilder filter
filter.discrete_sep <- function(type, id, name, ..., active = getOption("cb_active_filter", default = TRUE)) {
  args <- append(
    environment() %>% as.list() %>% purrr::keep(~ !is.symbol(.x)),
    list(...)
  )

  function(source) {
    do.call(
      cb_filter.discrete_sep,
      append(list(source = source), args)
    )
  }
}

#' cohortBuilder filter for discrete_sep
#' @param source Source
#' @param ... additional arguments.
#' @export
cb_filter.discrete_sep <- function(source, ...) {
  UseMethod("cb_filter.discrete_sep", source)
}

#' @importFrom cohortBuilder def_filter
#' @export
cb_filter.discrete_sep.tblist <- function(
    source, type = "discrete_sep", id = cohortBuilder::.gen_id(), name = id, dataset, variable,
    value = NA, keep_na = TRUE, description = NULL, sep = ",", ..., active = TRUE) {
  args <- list(...)

  def_filter(
    type = type,
    id = id,
    name = name,
    input_param = "value",
    filter_data = function(data_object) {

      selected_value <- value # code include
      if (keep_na && !identical(selected_value, NA)) {
        # keep_na !value_na start
        search_expr <- rlang::parse_exprs(
          glue::glue("is.na({var}) | grepl('(^|,|\\\\s){x}($|,)', {var})",
                     x = selected_value, var = variable)
        )
        data_object[[dataset]] <- data_object[[dataset]] %>%
          dplyr::filter(!!!search_expr)
        # keep_na !value_na end
      }
      if (!keep_na && identical(selected_value, NA)) {
        # !keep_na value_na start
        data_object[[dataset]] <- data_object[[dataset]] %>%
          dplyr::filter(!is.na(!!sym(variable)))
        # !keep_na value_na end
      }
      if (!keep_na && !identical(selected_value, NA)) {
        # !keep_na !value_na start
        search_expr <- rlang::parse_exprs(c(
          glue::glue("!is.na({var})", var = variable),
          glue::glue("grepl('(^|,|\\\\s){x}($|,)', {var})", x = selected_value, var = variable)
        ))
        data_object[[dataset]] <- data_object[[dataset]] %>%
          dplyr::filter(!!!search_expr)
        # !keep_na !value_na end
      }
      attr(data_object[[dataset]], "filtered") <- TRUE # code include
      data_object
    },
    get_stats = function(data_object, name) {
      if (missing(name)) {
        name <- c("n_data", "choices", "n_missing")
      }
      stats <- list(
        choices = if ("choices" %in% name) data_object[[dataset]][[variable]] %>%
          strsplit(split = ",", fixed = TRUE) %>%
          unlist() %>%
          stats::na.omit() %>%
          trimws() %>%
          table() %>%
          sort(decreasing = TRUE) %>%
          as.list(),
        n_data = if ("n_data" %in% name)  data_object[[dataset]][[variable]] %>%
          stats::na.omit() %>%
          length(),
        n_missing = if ("n_missing" %in% name) data_object[[dataset]][[variable]] %>% is.na() %>% sum()
      )
      if (length(name) == 1) {
        return(stats[[name]])
      } else {
        return(stats[name])
      }
    },
    plot_data = function(data_object) {
      if (nrow(data_object[[dataset]])) {
        data_object[[dataset]][[variable]] %>% table %>% prop.table() %>% graphics::barplot()
      } else {
        graphics::barplot(0, ylim = c(0, 0.1), main = "No data")
      }
    },
    get_params = function(name) {
      params <- list(
        dataset = dataset,
        variable = variable,
        value = value,
        description = description,
        keep_na = keep_na,
        active = active,
        sep = sep,
        ...
      )
      if (!missing(name)) return(params[[name]])
      return(params)
    },
    get_data = function(data_object) {
      data_object[[dataset]][[variable]]
    },
    get_defaults = function(data_object, cache_object) {
      list(value = names(cache_object$choices))
    }
  )
}

#' @importFrom shinyCohortBuilder .gui_filter
#' @export
.gui_filter.discrete_sep <- shinyCohortBuilder:::.gui_filter.discrete

#' @export
#'
cohortBuilder::filter