R/modifiers.R

In dynverse/dynguidelines: User guidelines for trajectory inference

default_modifier <- function(data, answers) {
  data$methods_aggr <- data$methods_aggr %>% arrange(-benchmark_overall_overall)

  # default benchmark
  benchmark_overall_overall <- methods_aggr %>%
    select(method_id, benchmark) %>%
    filter(!map_lgl(benchmark, is.null)) %>%
    tidyr::unnest(benchmark) %>%
    calculate_benchmark_score(answers = answers)
  data$methods_aggr$benchmark_overall_overall <- benchmark_overall_overall[data$methods_aggr$method_id]

  data$method_columns <- data$method_columns %>%
    add_row(column_id = "benchmark_overall_overall", order = TRUE)

  # default order
  data$methods_aggr <- data$methods_aggr %>% arrange(-benchmark_overall_overall)

  # add stability and error warning column
  scale_clip <- function(x, min, max) {
    case_when(
      x < min ~ 1,
      x < max ~ 1 - (x - min) / (max - min),
      TRUE ~ 0
    )
  }

  data$methods_aggr <- data$methods_aggr %>% mutate(
    stability_warning = scale_clip(stability_overall_overall, 0.5, 0.8),
    error_warning = 1 - scale_clip(benchmark_overall_pct_errored, 0.2, 0.5)
  )
  data$method_columns <- data$method_columns %>%
    add_row(column_id = "stability_warning", order = FALSE) %>%
    add_row(column_id = "error_warning", order = FALSE)

  data
}


multiple_disconnected_modifier <- function(data, answers) {
  if(isTRUE(answers$multiple_disconnected)) {
    data$methods_aggr <- data$methods_aggr %>% filter(method_detects_disconnected_graph)
    data$method_columns <- data$method_columns %>%
      add_row(column_id = "method_detects_disconnected_graph", filter = TRUE, order = FALSE)
  }
  data
}


expect_topology_modifier <- function(data, answers) {
  if (!isTRUE(answers$expect_topology)) {
    data$methods_aggr <- data$methods_aggr %>% filter(method_detects_linear & method_detects_bifurcation & method_detects_multifurcation & method_detects_tree)
    data$method_columns <- data$method_columns %>%
      bind_rows(
        tibble(
          column_id = c("method_detects_linear", "method_detects_bifurcation", "method_detects_multifurcation", "method_detects_tree"),
          filter = TRUE,
          order = FALSE
        )
      )
  }
  data
}


expected_topology_modifier <- function(data, answers) {
  trajectory_type_column <- paste0("method_detects_", answers$expected_topology)
  score_column <- paste0("benchmark_tt_", answers$expected_topology)

  trajectory_type_score <- methods_aggr %>%
    select(method_id, benchmark) %>%
    filter(!map_lgl(benchmark, is.null)) %>%
    tidyr::unnest(benchmark) %>%
    filter(dataset_trajectory_type == answers$expected_topology) %>%
    calculate_benchmark_score(answers = answers)
  data$methods_aggr[score_column] <- trajectory_type_score[data$methods_aggr$method_id]

  data$methods_aggr <- data$methods_aggr[data$methods_aggr[[trajectory_type_column]], ] %>% arrange(-.[[score_column]])
  data$method_columns <- data$method_columns %>%
    mutate(order = FALSE) %>%
    add_row(column_id = score_column, order = TRUE, filter = FALSE) %>%
    add_row(column_id = trajectory_type_column, filter = TRUE, order = FALSE)

  data
}


expect_cycles_modifier <- function(data, answers) {
  if(isTRUE(answers$expect_cycles)) {
    data$methods_aggr <- data$methods_aggr %>% filter(method_detects_graph & method_detects_cycle)
    data$method_columns <- data$method_columns %>%
      bind_rows(
        tibble(
          column_id = c("method_detects_graph", "method_detects_cycle"),
          filter = TRUE,
          order = FALSE
        )

      )
  }
  data
}


expect_complex_tree_modifier <- function(data, answers) {
  if(isTRUE(answers$expect_complex_tree)) {
    data$methods_aggr <- data$methods_aggr %>% arrange(-benchmark_tt_tree)
    data$method_columns <- data$method_columns %>%
      mutate(order = FALSE) %>%
      add_row(column_id = "benchmark_tt_tree", filter = FALSE, order = TRUE)
  }
  data
}

dynmethods_modifier <- function(data, answers) {
  data
}


programming_interface_modifier <- function(data, answers) {
  if (!isTRUE(answers$programming_interface)) {
    data$methods_aggr <- data$methods_aggr %>% filter(gui > 0)
  }

  data
}


languages_modifier <- function(data, answers) {
  data$methods_aggr <- data$methods_aggr %>% filter(method_platform %in% answers$languages)
  data$method_columns <- data$method_columns %>%
    add_row(column_id = "method_platform", filter = TRUE, order = FALSE)

  data
}


user_friendliness_modifier <- function(data, answers) {
  data$methods_aggr <- data$methods_aggr %>% filter(qc_app_user_friendly >= as.numeric(answers$user_friendliness)/100)
  data$method_columns <- data$method_columns %>%
    add_row(column_id = "qc_app_user_friendly", filter = TRUE, order = FALSE)

  data
}

developer_friendliness_modifier <- function(data, answers) {
  data$methods_aggr <- data$methods_aggr %>% filter(qc_app_developer_friendly >= as.numeric(answers$developer_friendliness)/100)
  data$method_columns <- data$method_columns %>%
    add_row(column_id = "qc_app_developer_friendly", filter = TRUE, order = FALSE)

  data
}



invoke_if_function <- function(func, ...) {
  if(!is.null(func)) {
    func(...)
  } else {
    NA
  }
}


time_modifier <- function(data, answers) {
  time_cutoff <- process_time(answers$time)

  if (!is.na(time_cutoff)) {
    n_cells <- ifelse(is.na(answers$n_cells), 1, answers$n_cells)
    n_features <- ifelse(is.na(answers$n_features), 1, answers$n_features)

    # calculate the time
    data$methods_aggr <- data$methods_aggr %>%
      mutate(
        scaling_predicted_time = map_dbl(
          scaling_models_predict_time,
          invoke_if_function,
          n_cells = n_cells,
          n_features = n_features
        )
      )

    # filter on time
    data$methods_aggr <- data$methods_aggr %>%
      filter(is.na(scaling_predicted_time) | scaling_predicted_time <= time_cutoff)

    # add to method columns
    data$method_columns <- data$method_columns %>%
      add_row(column_id = "scaling_predicted_time", filter = TRUE, order = FALSE)
  }
  data
}

memory_modifier <- function(data, answers) {
  memory_cutoff <- process_memory(answers$memory)
  if (!is.na(memory_cutoff)) {
    n_cells <- ifelse(is.na(answers$n_cells), 1, answers$n_cells)
    n_features <- ifelse(is.na(answers$n_features), 1, answers$n_features)

    # calculate the memory
    data$methods_aggr <- data$methods_aggr %>%
      mutate(
        scaling_predicted_mem = map_dbl(
          scaling_models_predict_mem,
          invoke_if_function,
          n_cells = n_cells,
          n_features = n_features
        )
      )

    # filter on memory
    data$methods_aggr <- data$methods_aggr %>%
      filter(is.na(scaling_predicted_mem) | scaling_predicted_mem <= memory_cutoff)

    # add to method columns
    data$method_columns <- data$method_columns %>%
      add_row(column_id = "scaling_predicted_mem", filter = TRUE, order = FALSE)
  }

  data
}


prior_information_modifier <- function(data, answers) {
  unavailable_priors <- dynwrap::priors %>% filter(!prior_id %in% answers$prior_information) %>% pull(prior_id)
  data$methods_aggr <- data$methods_aggr %>%
    filter(
      map_lgl(method_required_priors, ~!any(. %in% unavailable_priors))
    )

  data
}


method_selection_modifier <- function(data, answers) {
  data
}


dynamic_n_methods_modifier <- function(data, answers) {
  data$methods_aggr <- data$methods_aggr %>%
    mutate(selected = row_number() < 5)
  data$method_columns <- data$method_columns %>%
    add_row(column_id = "selected", filter = FALSE, order = FALSE)
  data$methods_selected <- data$methods_aggr %>% filter(selected) %>% pull(method_id)

  data
}


fixed_n_methods_modifier <- function(data, answers) {
  data$methods_aggr <- data$methods_aggr %>%
    mutate(selected = row_number() < answers$fixed_n_methods+1)
  data$method_columns <- data$method_columns %>%
    add_row(column_id = "selected", filter = FALSE, order = FALSE)
  data$methods_selected <- data$methods_aggr %>% filter(selected) %>% pull(method_id)

  data
}


n_cells_modifier <- function(data, answers) {
  data
}


n_features_modifier <- function(data, answers) {
  data
}


docker_modifier <- function(data, answers) {
  data
}


metric_importance_modifier <- function(data, answers) {
  data
}





calculate_benchmark_score <- function(benchmark, answers) {
  benchmark %>%
    filter(!dataset_id %in% answers$exclude_datasets) %>%
    group_by(method_id, dataset_trajectory_type) %>%
    summarise_if(is.numeric, mean) %>%
    summarise_if(is.numeric, mean) %>%
    mutate(score = dynutils::calculate_geometric_mean(.[, benchmark_metrics$metric_id], weights = unlist(answers$metric_importance[benchmark_metrics$metric_id]))) %>%
    select(method_id, score) %>%
    deframe()
}