R/method-grim-sequence.R

In lhdjung/scrutiny: Error Detection in Science

# Non-exported helper function that, by default, shows a message when the
# results of the main function (at the bottom) are returned:

explain_seq_test_ranking <- function(x, scr_func_info) {

  if (!any(colnames(x) == "lead_lag")) {
    x$lead_lag <- NA
  }

  cons <- x$consistent[!is.na(x$consistent)]
  incons <- x$inconsistent[!is.na(x$inconsistent)]
  lead <- x$lead_lag[!is.na(x$lead_lag)]

  l_cons <- length(cons)
  l_incons <- length(incons)
  l_lead <- length(lead)

  if (l_lead > 0L) {
    if (l_lead > 1L) {
      if (all(lead > 0)) {
        lead_lag_info <- "lead"
      } else if (all(lead < 0)) {
        lead_lag_info <- "lag"
      } else {
        lead_lag_info <- "lead or lag"
      }
    } else {
      if (lead > 0) {
        lead_lag_info <- "leads"
      } else {
        lead_lag_info <- "lags"
      }
    }
  }

  lead <- abs(lead)

  df_info <- glue::glue("the data frame created by {scr_func_info}")

  if (l_cons == 0L) {
    cli::cli_inform(c(
      "Explanation: ",
      "i" = "All value sets of {df_info} are inconsistent. \n"
    ))
  } else if (l_incons == 0L) {
    cli::cli_inform(c(
      "Explanation: ",
      "i" = "All value sets of {df_info} are consistent. \n"
    ))
  } else {
    if (l_cons == 1L) {
      msg_cons <- glue::glue("There is only 1 consistent value set. It's \\
                             in row number {cons} of {df_info}.")
      msg_lead <- glue::glue("The consistent value set {lead_lag_info} the \\
                             first inconsistent one by {lead} places in the \\
                             {scr_func_info} data frame. \n")
    } else if (l_cons == 2L) {
      msg_cons <- glue::glue("There are 2 consistent value sets, in rows \\
                             number {cons[1L]} and {cons[2L]} of {df_info}.")
      msg_lead <- glue::glue("The consistent sets {lead_lag_info} the \\
                             inconsistent ones by {lead[1L]} and {lead[2L]} \\
                             places, respectively, in the {scr_func_info} \\
                             data frame. \n")
    } else {
      msg_cons <- glue::glue("There are {l_cons} consistent value sets, \\
                             starting with row number {cons[1L]} in \\
                             {df_info}.")
      msg_lead <- glue::glue("The consistent sets {lead_lag_info} the \\
                             inconsistent ones by numbers of places from \\
                             {lead[1L]} to {lead[l_lead]} in the \\
                             {scr_func_info} data frame. \n")
    }
    msg_incons <- "All other value sets are inconsistent."
    cli::cli_inform(c(
      "Explanation: ",
      "i" = msg_cons,
      "i" = msg_incons,
      "i" = msg_lead
    ))
  }

}



#' Rank sequence test results
#'
#' @description  Run this function after generating a sequence with
#'   `seq_endpoint_df()` or `seq_distance_df()` and testing it with one of
#'   scrutiny's mapping functions, such as `grim_map()`. It will rank the test's
#'   consistent and inconsistent results by their positions in the sequence.
#'
#' @details The function checks the provenance of the test results and throws a
#'   warning if it's not correct.
#'
#' @param x Data frame.
#' @param explain If `TRUE` (the default), results come with an explanation.
#'
#' @return A tibble (data frame). The function will also print an explanation of
#'   the results. See examples.
#'
#' @export
#'
#' @examples
#' seq_distance_df(.from = "0.00", n = 50) %>%
#'   grim_map() %>%
#'   seq_test_ranking()


seq_test_ranking <- function(x, explain = TRUE) {

  if (!any(colnames(x) == "consistency")) {
    cli::cli_abort(c(
      "Column `consistency` is missing.",
      "i" = "Only run `seq_test_ranking()` on the output of a \\
      mapping function, and only if that function was called to test a \\
      sequence generated by a function like one of scrutiny's `seq_*_df()` \\
      functions."
    ))
  }

  consistent <- which(x$consistency == TRUE)
  inconsistent <- which(x$consistency == FALSE)

  l_cons <- length(consistent)
  l_incons <- length(inconsistent)

  greater_l <- max(l_cons, l_incons)
  lesser_l <- min(l_cons, l_incons)

  difference <- greater_l - lesser_l
  na_annex <- rep(NA, difference)

  if (l_cons > l_incons) {
    inconsistent <- append(inconsistent, na_annex)
  } else {
    consistent <- append(consistent, na_annex)
  }

  if (all(is.na(consistent))) {
    out <- tibble::tibble(consistent, inconsistent)
  } else {
    lead_lag <- inconsistent - consistent
    out <- tibble::tibble(consistent, inconsistent, lead_lag)
  }

  out <- add_class(out, "seq_test_ranking")

  class_is_scr_map_class <-
    stringr::str_detect(class(x), "^scr_") &
    stringr::str_detect(class(x), "_map$")
  scr_func_info <- class(x)[class_is_scr_map_class]
  scr_func_info <- stringr::str_remove(scr_func_info, "^scr_")
  scr_func_info <- paste0("`", scr_func_info, "()`")

  if (inherits(x, "scr_seq_test")) {
    if (explain) {
      explain_seq_test_ranking(out, scr_func_info)
    }
    out
  } else {
    if (any(class_is_scr_map_class)) {
      scr_func_info <- paste0(" with ", scr_func_info)
    } else {
      scr_func_info <- ""
    }
    cli::cli_warn(c(
      "Is that really a sequence test?",
      "!" = "The data frame you tested{scr_func_info} wasn't created by \\
      `seq_endpoint_df()` or `seq_distance_df()`.",
      ">" = "Make sure you really tested a sequence. If you didn't, the \\
      results of `seq_test_ranking()` are probably not interpretable."
    ))
    out
  }

}