R/answers.R

In dynverse/dynguidelines: User guidelines for trajectory inference

## Answer questions
# get default answers based on questions
get_defaults <- function(question_ids = names(get_questions())) {
  questions <- get_questions()[question_ids]
  map(questions, ~if(is.function(.$default)) {.$default()} else {.$default}) %>% set_names(names(questions))
}

get_default <- function(question_id, questions = get_questions()) {
  default <- questions[[question_id]][["default"]]

  default
}

# function which generates the documentation for the answers function based on all the questions
answer_questions_docs <- function() {
  questions <- get_questions()
  parameters <- paste0(
    "@param ... Answers to questions: \n",
    glue::glue(
      " - {names(questions)}: {map_chr(questions, 'label')} defaults to `{get_defaults(names(questions)) %>% as.character()}`: "
    ) %>% glue::glue_collapse("\n")
  )

  parameters
}

#' Provide answers to questions
#'
#' @include questions.R
#' @param dataset The dynwrap dataset object from which the answers will be computed
#' @eval answer_questions_docs()
#'
#' @export
answer_questions <- function(dataset = NULL, ...) {
  questions <- get_questions()

  # get either the defaults or the arguments given by the user
  given_answers <- list(...)
  default_answers <- get_defaults(names(questions))
  default_answers <- default_answers[setdiff(names(default_answers), names(given_answers))]
  answers <- c(given_answers, default_answers)

  # get computed answers from dataset
  computed_question_ids <- character()
  if (!is.null(dataset)) {
    for (question_id in setdiff(names(questions), names(given_answers))) {
      if (is.function(questions[[question_id]]$default_dataset)) {
        new_default <- questions[[question_id]]$default_dataset(dataset, answers[[question_id]])
        new_default <- list(new_default)  # use list here to avoid xxx <- NULL removing the element
        answers[question_id] <- new_default
        computed_question_ids <- c(computed_question_ids, question_id)
      }
    }
  }

  for (question_id in setdiff(names(questions), names(given_answers))) {
    if (is.function(questions[[question_id]]$default)) {
      computed_question_ids <- c(computed_question_ids, question_id)
    }
  }

  tibble(
    question_id = names(answers),
    answer = answers,
    source = case_when(
      question_id %in% names(given_answers) ~ "adapted",
      question_id %in% computed_question_ids ~ "computed",
      TRUE ~ "default"
    )
  )
}

#' Produces the code necessary to reproduce guidelines given a set of answers
#'
#' @param answers An answers tibble as generated by [answer_questions()]
#'
#' @export
get_answers_code <- function(answers = answer_questions()) {
  params <- c()

  adapted_answers <- answers %>% filter(source %in% c("computed", "adapted"))
  params <-
    map2_chr(adapted_answers$question_id, adapted_answers$answer, function(question_id, answer) {
      glue::glue("{question_id} = {glue::glue_collapse(deparse(answer, width.cutoff = 80L))}")
    })

  if (length(params) == 0) {
    code <- "answers <- dynguidelines::answer_questions()"
  } else {
    code <- glue::glue(
      "answers <- dynguidelines::answer_questions(",
      glue::glue_collapse(paste0("  ", params), ", \n"),
      ")",
      .sep = "\n",
      .trim = FALSE
    )
  }

  code <- paste(
    "# Reproduces the guidelines as created in the shiny app",
    code,
    "guidelines <- dynguidelines::guidelines(answers = answers)",
    sep = "\n"
  )

  code
}