tests/testthat/test-agg_methods.R

In aggreCAT: Mathematically Aggregating Expert Judgments

library(pointblank)


method_schema_default <- function(method_to_test, type){

  tbl <- data_ratings %>%
    method_to_test(type = {{type}}, percent_toggle = TRUE)

  test_that("column `method` exists", {

    expect_col_exists(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })


  test_that("column `paper_id` exists", {

    expect_col_exists(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("column `cs` exists", {

    expect_col_exists(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("column `n_experts` exists", {

    expect_col_exists(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })


  test_that("values in `n_experts` should be between `0` and `25`", {

    expect_col_vals_between(
      tbl,
      columns = vars(n_experts),
      left = 0,
      right = 25,
      threshold = 1
    )
  })


  test_that("values in `cs` should be between `0` and `1`", {

    expect_col_vals_between(
      tbl,
      columns = vars(cs),
      left = 0,
      right = 1,
      threshold = 1
    )
  })


  test_that("column `method` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("column `paper_id` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })


  test_that("column `n_experts` is of type: integer", {

    expect_col_is_integer(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

  test_that("all values in `method` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("all values in `paper_id` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("all values in `cs` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("all values in `n_experts` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

}

# Measures of unweighted aggregation
method_schema_default(AverageWAgg, type = "ArMean")
method_schema_default(AverageWAgg, type = "Median")
method_schema_default(AverageWAgg, type = "GeoMean")
method_schema_default(AverageWAgg, type = "LOArMean")
method_schema_default(AverageWAgg, type = "ProbitArMean")

method_schema_default(LinearWAgg, type = "DistLimitWAgg")
method_schema_default(LinearWAgg, type = "GranWAgg")
method_schema_default(LinearWAgg, type = "OutWAgg")

method_schema_default(IntervalWAgg, type = "IntWAgg")
method_schema_default(IntervalWAgg, type = "IndIntWAgg")
method_schema_default(IntervalWAgg, type = "AsymWAgg")
method_schema_default(IntervalWAgg, type = "IndIntAsymWAgg")
method_schema_default(IntervalWAgg, type = "VarIndIntWAgg")
method_schema_default(IntervalWAgg, type = "KitchSinkWAgg")

method_schema_default(DistributionWAgg, type = "DistribArMean")
method_schema_default(DistributionWAgg, type = "TriDistribArMean")

method_schema_default(ShiftingWAgg, type = "ShiftWAgg")
method_schema_default(ShiftingWAgg, type = "BestShiftWAgg")
method_schema_default(ShiftingWAgg, type = "IntShiftWAgg")
method_schema_default(ShiftingWAgg, type = "DistShiftWAgg")
method_schema_default(ShiftingWAgg, type = "DistIntShiftWAgg")



# Method Test Needing Additional Arguments --------------------------------


method_schema_linear_weights <- function(method_to_test, weights, type, name){

  tbl <- data_ratings %>%
    method_to_test(weights, type = {{type}} , name = {{name}}, percent_toggle = TRUE)

  test_that("column `method` exists", {

    expect_col_exists(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })


  test_that("column `paper_id` exists", {

    expect_col_exists(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("column `cs` exists", {

    expect_col_exists(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("column `n_experts` exists", {

    expect_col_exists(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })


  test_that("values in `n_experts` should be between `0` and `25`", {

    expect_col_vals_between(
      tbl,
      columns = vars(n_experts),
      left = 0,
      right = 25,
      threshold = 1
    )
  })


  test_that("values in `cs` should be between `0` and `1`", {

    expect_col_vals_between(
      tbl,
      columns = vars(cs),
      left = 0,
      right = 1,
      threshold = 1
    )
  })


  test_that("column `method` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("column `paper_id` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })


  test_that("column `n_experts` is of type: integer", {

    expect_col_is_integer(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

  test_that("all values in `method` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("all values in `paper_id` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("all values in `cs` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("all values in `n_experts` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

}



# LinearWAgg Additional Arguments -----------------------------------------

method_schema_linear_weights(LinearWAgg,
                             weights = data_supp_quiz %>%
                               dplyr::rename(weight = quiz_score),
                             type = "Participant_LO",
                             name = "QuizWAgg")
#
#
# method_schema_linear_weights(LinearWAgg,
#                              weights = data_ratings %>%
#                                dplyr::filter(element == "three_point_best",
#                                              round == "round_2") %>%
#                                dplyr::select(paper_id,
#                                              user_name,
#                                              timestamp) %>%
#                                dplyr::group_by(user_name) %>%
#                                dplyr::arrange(timestamp) %>%
#                                dplyr::mutate(claim_count = dplyr::row_number()) %>%
#                                dplyr::ungroup() %>%
#                                dplyr::mutate(weight = log(claim_count) + 1) %>%
#                                dplyr::select(paper_id,
#                                              user_name,
#                                              weight),
#                              type = "Judgement",
#                              name = "ExperienceWAgg")

method_schema_linear_weights(LinearWAgg,
                             weights = data_ratings %>%
                               dplyr::filter(question == "comprehension",
                                             round == "round_2") %>%
                               dplyr::select(paper_id,
                                             user_name,
                                             value) %>%
                               dplyr::rename(weight = value),
                             type = "Judgement",
                             name = "CompWAgg")

method_schema_linear_weights(LinearWAgg,
                             weights = data_justifications %>%
                               dplyr::mutate(n_words = stringr::str_count(justification, pattern = " ") + 1) %>%
                               dplyr::group_by(user_name,
                                               paper_id) %>%
                               dplyr::summarise(word_count = sum(n_words,
                                                                 na.rm = TRUE)) %>%
                               dplyr::select(paper_id,
                                             user_name,
                                             word_count) %>%
                               dplyr::rename(weight = word_count),
                             type = "Judgement",
                             name = "EngWAgg")


# Reasoning ---------------------------------------------------------------


method_schema_reasoning <- function(method_to_test, reasons, type, name, beta_transform){

  tbl <- data_ratings %>%
    method_to_test(reasons, type = {{type}} , name = {{name}}, beta_transform = {{beta_transform}}, percent_toggle = TRUE)

  test_that("column `method` exists", {

    expect_col_exists(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })


  test_that("column `paper_id` exists", {

    expect_col_exists(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("column `cs` exists", {

    expect_col_exists(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("column `n_experts` exists", {

    expect_col_exists(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })


  test_that("values in `n_experts` should be between `0` and `25`", {

    expect_col_vals_between(
      tbl,
      columns = vars(n_experts),
      left = 0,
      right = 25,
      threshold = 1
    )
  })


  test_that("values in `cs` should be between `0` and `1`", {

    expect_col_vals_between(
      tbl,
      columns = vars(cs),
      left = 0,
      right = 1,
      threshold = 1
    )
  })


  test_that("column `method` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("column `paper_id` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })


  test_that("column `n_experts` is of type: integer", {

    expect_col_is_integer(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

  test_that("all values in `method` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("all values in `paper_id` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("all values in `cs` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("all values in `n_experts` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

}



method_schema_reasoning(ReasoningWAgg,
                        reasons = data_supp_reasons,
                        type = "ReasonWAgg",
                        name = "ReasonWAgg",
                        beta_transform = FALSE)

method_schema_reasoning(ReasoningWAgg,
                        reasons = data_supp_reasons,
                        type = "ReasonWAgg2",
                        name = "ReasonWAgg2",
                        beta_transform = FALSE)

method_schema_reasoning(ReasoningWAgg,
                        reasons = data_supp_reasons,
                        type = "ReasonWAgg",
                        name = "BetaReasonWAgg",
                        beta_transform = TRUE)

method_schema_reasoning(ReasoningWAgg,
                        reasons = data_supp_reasons,
                        type = "ReasonWAgg2",
                        name = "BetaReasonWAgg2",
                        beta_transform = TRUE)


# Bayes --------------------------------------------------------------------



method_schema_bays <- function(method_to_test, priors, type, name){

  tbl <- data_ratings %>%
    method_to_test(priors, type = {{type}} , name = {{name}}, percent_toggle = TRUE)

  test_that("column `method` exists", {

    expect_col_exists(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })


  test_that("column `paper_id` exists", {

    expect_col_exists(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("column `cs` exists", {

    expect_col_exists(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("column `n_experts` exists", {

    expect_col_exists(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })


  test_that("values in `n_experts` should be between `0` and `25`", {

    expect_col_vals_between(
      tbl,
      columns = vars(n_experts),
      left = 0,
      right = 25,
      threshold = 1
    )
  })


  test_that("values in `cs` should be between `0` and `1`", {

    expect_col_vals_between(
      tbl,
      columns = vars(cs),
      left = 0,
      right = 1,
      threshold = 1
    )
  })


  test_that("column `method` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("column `paper_id` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })


  test_that("column `n_experts` is of type: integer", {

    expect_col_is_integer(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

  test_that("all values in `method` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("all values in `paper_id` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("all values in `cs` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("all values in `n_experts` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

}

# method_schema_bays(BayesianWAgg, priors = NULL, type = "BayTriVar", name = "BayTriVar")

# method_schema_bays(BayesianWAgg, priors = data_supp_priors, type = "BayPRIORsAgg", name = "BayTriVar")


# Extreme Wag -------------------------------------------------------------

method_schema_extreme <- function(method_to_test, type, name, cutoff_lower, cutoff_upper){


  tbl <- data_ratings %>%
    method_to_test(type = {{type}} , name = {{name}}, cutoff_lower = {{cutoff_lower}}, cutoff_upper = {{cutoff_upper}}, percent_toggle = TRUE)

  test_that("column `method` exists", {

    expect_col_exists(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })


  test_that("column `paper_id` exists", {

    expect_col_exists(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("column `cs` exists", {

    expect_col_exists(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("column `n_experts` exists", {

    expect_col_exists(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })


  test_that("values in `n_experts` should be between `0` and `25`", {

    expect_col_vals_between(
      tbl,
      columns = vars(n_experts),
      left = 0,
      right = 25,
      threshold = 1
    )
  })


  test_that("values in `cs` should be between `0` and `1`", {

    expect_col_vals_between(
      tbl,
      columns = vars(cs),
      left = 0,
      right = 1,
      threshold = 1
    )
  })


  test_that("column `method` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("column `paper_id` is of type: character", {

    expect_col_is_character(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })


  test_that("column `n_experts` is of type: integer", {

    expect_col_is_integer(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })

  test_that("all values in `method` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(method),
      threshold = 1
    )
  })

  test_that("all values in `paper_id` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(paper_id),
      threshold = 1
    )
  })

  test_that("all values in `cs` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(cs),
      threshold = 1
    )
  })

  test_that("all values in `n_experts` should not be NULL", {

    expect_col_vals_not_null(
      tbl,
      columns = vars(n_experts),
      threshold = 1
    )
  })


}

method_schema_extreme(ExtremisationWAgg,
                      type = "BetaArMean",
                      name = "BetaArMean",
                      cutoff_lower = NULL,
                      cutoff_upper = NULL)

method_schema_extreme(ExtremisationWAgg,
                      type = "BetaArMean2",
                      name = "BetaArMean2",
                      cutoff_lower = 0.4,
                      cutoff_upper = 0.6)