---
title: "Implementing custom filters"
output: rmarkdown::html_vignette
vignette: >
  %\VignetteIndexEntry{Implementing custom filters}
  %\VignetteEngine{knitr::rmarkdown}
  %\VignetteEncoding{UTF-8}
---

```{r setup, include = FALSE}
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>"
)
options("tibble.print_min" = 5, "tibble.print_max" = 5)
library(magrittr)
library(dplyr, exclude = "filter")
library(cohortBuilder)
```

`cohortBuilder` itself provides five types of filters that are suitable to perform
most common filtering tasks:

- discrete,
- range,
- date_range,
- discrete_text,
- multi_discrete.

If any of the above filters doesn't meet your need, you may want to create a custom one.
Below we describe in details how new filters can be created and provide an example for creating a new one - logical filter.

## Filter structure

Before we start let's make a closer look about what R object the filter is.

The `filter` function itself is S3 method taking `type` as a first argument.

```{r}
filter
```

So in case of `discrete` filter, the proper used method is:

```{r}
cohortBuilder:::filter.discrete
```

that gathers provided parameters and returns function of `source` argument:

```{r}
spec_filter <- filter("discrete", value = "setosa", dataset = "iris", variable = "Species")
spec_filter
```

So whenever we define filter of specific type it returns unevaluated function of `source` parameter.

We can realize, the function itself calls another S3 method `cb_filter.discrete`, that takes into account type of the provided source.

```{r}
cb_filter.discrete
```

With such approach for having two layers of S3 methods, we are allowed to to build various filter types, for various source types.
For example discrete filter for tblist source, discrete filter for db source, range filter for raw source etc.

Now, let's check what object stores filter evaluated on source:

```{r}
iris_source <- set_source(
  tblist(iris = iris)
)
str(
  spec_filter(iris_source),
  give.attr = FALSE
)
```

We can see, the evaluated filter is a list of 10 elements:

- `type` - Filter type.
- `id` - Filter id.
- `name` - Filter name.
- `input_param` - Name of the parameter taking filtering value.
- `filter_data` - Function of 'data_object' parameter defining filtering logic on Source data object.
- `get_stats` - Function of 'data_object' and 'name' parameters defining what and how data statistics should be calculated.
- `plot_data` - Function of 'data_object' parameter defining how filter data should be plotted.
- `get_params` - Function of 'name' parameter returning filter parameter (or all parameters when name is missing).
- `get_data` - Function of 'data_object' returning filter related data.
- `get_defaults` - Function of 'data_object' and 'cache_object' parameters returning default 'input_param' parameter value.

Where:

- `data_object` is an object passed to and returned from each filtering step (in more details, following the structure returned by `init_source` S3 method).
- `cache_object` is result of `get_stats` method for the previous step.

## Logical filter

In case you want to create a new filter definition, you may use `new_filter` to initialize it from template.

Below we'll create a new filter that takes logical value and filters logical column accordingly.
Let's name type of the filter as 'logical'.
The filter will work on 'tblist' source data (list of data frames).

To do so, we need to:

1. Create `filter.logical` S3 method that is called when type of filter is 'logical'.
2. Create generic `cb_filter.logical` that operates based on source type.

```{r}
filter.logical <- function(type, id, name, ..., active = getOption("cb_active_filter", default = TRUE)) {
  # Skip missing parameters passed and attach `...`
  args <- append(
    environment() %>% as.list() %>% purrr::keep(~ !is.symbol(.x)),
    list(...)
  )

  # Return function of source parameter calling valid S3 method based on source type
  function(source) {
    do.call(
      cb_filter.logical,
      append(list(source = source), args)
    )
  }
}
```

Create `cb_filter.logical` generic used in the above method (skip when method already exists).

```{r}
cb_filter.logical <- function(source, ...) {
  UseMethod("cb_filter.logical", source)
}
```

Create S3 method for specific source data type ('tblist' in this case).
Here we define list of parameters required by filter.

The obligatory parameters are:


- `source`,
- `type` - equals filter type by default,
- `id` - should be randomly generated by default, `.gen_id()`,
- `name` - used only for improving readiness of various outputs. Can be reassigned from id,
- `active` - the parameter that configures whether filter should be used or not (even if defined).

More to that you should define parameters that allow filter configuration related to data.

In our case we need to configure:

- The dataset name to be used - `dataset`.
- The variable used for filtering - `variable`.
- Filtering value - `value`. Regarding value, `cohortBuilder` assumes `value = NA` means no filtering is applied.
  This needs to be handled while writing filtering logic.
- Extra filter parameters - `...`. Accessible via `get_params` method - see below.

We can also add an extra parameter `keep_na` which determines whether `NA` values should be included or not.
It's also worth to add `description` parameter, storing helpful information about the defined filter.

Now we create source specific S3 method for `cb_filter.logical`.
Inside of the method we call `def_filter` completing all of the parameters based on filter configuration.

```{r}
cb_filter.logical.tblist <- function(
  source, type = "logical", id = .gen_id(), name = id, dataset, variable, 
  value = NA, keep_na = TRUE, description = NULL, ..., 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
        data_object[[dataset]] <- data_object[[dataset]] %>%
          dplyr::filter(!!sym(variable) == !!selected_value | is.na(variable))
        # 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
        data_object[[dataset]] <- data_object[[dataset]] %>%
          dplyr::filter(!!sym(variable) %in% !!selected_value & !is.na(variable))
        # !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]] %>% 
          stats::na.omit() %>% table() %>% 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,
        ...
      )
      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))
    }
  )
}
```

Please note that:

1. When filter parameter value equals NA, we assume no filtering is done at all (unless we define `keep_na = TRUE`).
2. While defining `filter_data` we add a few comment blocks that affect reproducible code output:
- configurations of `(!)keep_na (!)value_na (start|end)` - states which filtering case are we in.
- inline `code include` comments, or `code include (start|end)` designates which code lines to include in reproducible code. 
This way we can easily control which parts of filtering logic should reproducible code include.
When writing custom filters in a separate package please add `keepSource: true` in the description to preserve comments after compilation.
3. When defining `get_stats`, we took care to evaluate only the selected stat (if `name` is not missing).
Such implementation is not obligatory, but helps to improve performance if we operate with large source data.
4. `filter_data` method doesn't change the structure of `data_object`.
5. `filter_data` attaches `filtered` attribute to affected dataset. 
This way, whenever `filter_data` is called (filter is active), we can handle such information while running bindings.
If no bindings are used, this step can be skipped.

Now we can use our filter for building cohort.

For the example we'll use extended `iris` table:

```{r}
iris2 <- dplyr::mutate(iris, is_setosa = Species == "setosa")
coh <- set_source(tblist(iris = iris2)) %>%
  cohort(
    filter("logical", dataset = "iris", variable = "is_setosa", value = TRUE)
  ) %>%
  run()
```
