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

## -----------------------------------------------------------------------------
spec_filter <- filter("discrete", value = "setosa", dataset = "iris", variable = "Species")
spec_filter

## -----------------------------------------------------------------------------
spec_filter@type
spec_filter@variable
spec_filter@value
spec_filter@dataset

## -----------------------------------------------------------------------------
str(get_filter_params(spec_filter))

## -----------------------------------------------------------------------------
CbFilterLogical <- S7::new_class("CbFilterLogical",
  parent = CbFilter,
  properties = list(
    dataset = S7::class_character,
    variable = S7::class_character,
    value = S7::class_any,
    keep_na = S7::class_logical
  ),
  constructor = function(id = NULL, name = NULL, variable, value = NA,
                         dataset, keep_na = TRUE, description = NULL,
                         active = getOption("cb_active_filter", default = TRUE), ...) {
    if (is.null(id)) id <- paste(dataset, variable, sep = "-")
    if (is.null(name)) name <- variable
    S7::new_object(S7::S7_object(),
      type = "logical", id = id, name = name, input_param = "value",
      variable = variable, value = value, dataset = dataset,
      keep_na = keep_na, active = active, description = description,
      extra = list(...)
    )
  }
)

## -----------------------------------------------------------------------------
register_filter_type("logical", CbFilterLogical)

## -----------------------------------------------------------------------------
my_filter <- filter("logical", variable = "is_setosa", dataset = "iris", value = TRUE)
my_filter@type
my_filter@value

## -----------------------------------------------------------------------------
S7::method(cb_filter_data, list(CbFilterLogical, tblist_class)) <- function(filter, source, data_object, ...) {
  dataset <- filter@dataset
  variable <- filter@variable
  value <- filter@value
  keep_na <- filter@keep_na

  if (keep_na && !identical(value, NA)) {
    data_object[[dataset]] <- data_object[[dataset]] |>
      dplyr::filter(!!sym(variable) == !!value | is.na(!!sym(variable)))
  }
  if (!keep_na && identical(value, NA)) {
    data_object[[dataset]] <- data_object[[dataset]] |>
      dplyr::filter(!is.na(!!sym(variable)))
  }
  if (!keep_na && !identical(value, NA)) {
    data_object[[dataset]] <- data_object[[dataset]] |>
      dplyr::filter(!!sym(variable) == !!value)
  }
  attr(data_object[[dataset]], "filtered") <- TRUE
  data_object
}

## -----------------------------------------------------------------------------
S7::method(cb_get_filter_stats, list(CbFilterLogical, tblist_class)) <- function(
  filter, source, data_object, name, ...
) {
  dataset <- filter@dataset
  variable <- filter@variable
  if (missing(name)) {
    name <- c("n_data", "choices", "n_missing")
  }
  column <- data_object[[dataset]][[variable]]
  stats <- list(
    choices = if ("choices" %in% name) as.list(table(stats::na.omit(column))),
    n_data = if ("n_data" %in% name) length(stats::na.omit(column)),
    n_missing = if ("n_missing" %in% name) sum(is.na(column))
  )
  if (length(name) == 1L) stats[[name]] else stats[name]
}

## -----------------------------------------------------------------------------
S7::method(cb_plot_filter_data, list(CbFilterLogical, tblist_class)) <- function(filter, source, data_object, ...) {
  dataset <- filter@dataset
  variable <- filter@variable
  if (nrow(data_object[[dataset]])) {
    data_object[[dataset]][[variable]] |> table() |> prop.table() |> graphics::barplot(...)
  } else {
    graphics::barplot(0.0, ylim = c(0.0, 0.1), main = "No data")
  }
}

## -----------------------------------------------------------------------------
S7::method(cb_get_filter_data, list(CbFilterLogical, tblist_class)) <- function(filter, source, data_object, ...) {
  data_object[[filter@dataset]][[filter@variable]]
}

## -----------------------------------------------------------------------------
S7::method(cb_get_filter_defaults, list(CbFilterLogical, tblist_class)) <- function(
  filter, source, data_object, cache_object, ...
) {
  list(value = names(cache_object$choices))
}

## -----------------------------------------------------------------------------
S7::method(cb_filter_to_expr, list(CbFilterLogical, tblist_class)) <- function(filter, source, ...) {
  dataset <- filter@dataset
  variable <- filter@variable
  value <- filter@value
  keep_na <- filter@keep_na

  if (keep_na && !identical(value, NA)) {
    rlang::expr({
      data_object[[!!dataset]] <- data_object[[!!dataset]] |>
        dplyr::filter(!!sym(variable) == !!value | is.na(!!sym(variable)))
    })
  } else if (!keep_na && identical(value, NA)) {
    rlang::expr({
      data_object[[!!dataset]] <- data_object[[!!dataset]] |>
        dplyr::filter(!is.na(!!sym(variable)))
    })
  } else if (!keep_na && !identical(value, NA)) {
    rlang::expr({
      data_object[[!!dataset]] <- data_object[[!!dataset]] |>
        dplyr::filter(!!sym(variable) == !!value)
    })
  } else {
    NULL
  }
}

## -----------------------------------------------------------------------------
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()

## -----------------------------------------------------------------------------
nrow(get_data(coh)$iris)
collapse::funique(get_data(coh)$iris$is_setosa)

## -----------------------------------------------------------------------------
stat(coh, step_id = 1L, filter_id = 1L)

## -----------------------------------------------------------------------------
code(coh, include_methods = NULL, include_action = NULL)

## -----------------------------------------------------------------------------
my_filter <- filter("logical",
  dataset = "iris", variable = "is_setosa", value = TRUE,
  gui_input = "checkbox"
)
my_filter@extra$gui_input
get_filter_params(my_filter)$gui_input