self_ranking argument

DESCRIPTION

@@ -67,6 +67,7 @@ Suggests:
     datamods,
     DT,
     roxygen2,
+    shinyWidgets,
     testthat (>= 3.0.0),
     withr,
     writexl

R/mtscr_app.R

@@ -46,9 +46,9 @@
 #' }
 mtscr_app <- function(debug_mode = 0) {
   needed_packages <- if (debug_mode == 2) {
-    c("DT", "broom.mixed", "datamods", "writexl", "INVALID_PACKAGE")
+    c("DT", "datamods", "writexl", "shinyWidgets", "INVALID_PACKAGE")
   } else {
-    c("DT", "broom.mixed", "datamods", "writexl")
+    c("DT", "datamods", "writexl", "shinyWidgets")
   }
 
   needed_packages <- sapply(needed_packages, \(x) {

R/mtscr_model.R

@@ -31,7 +31,7 @@
 #' # extract effects for creativity score by hand
 #' model <- mtscr_model(mtscr_creativity, id, item, SemDis_MEAN, top = 2)
 #' creativity_score <- glmmTMB::ranef(model)$cond$id[, 1]
-mtscr_model <- function(df, id_column, item_column = NULL, score_column, top = 1, prepared = FALSE, ties_method = c("random", "average")) {
+mtscr_model <- function(df, id_column, item_column = NULL, score_column, top = 1, prepared = FALSE, ties_method = c("random", "average"), self_ranking = NULL) {
   id_column <- rlang::ensym(id_column)
   item_column_quo <- rlang::enquo(item_column)
   if (!rlang::quo_is_null(item_column_quo)) {
@@ -40,8 +40,11 @@ mtscr_model <- function(df, id_column, item_column = NULL, score_column, top = 1
     item_column <- item_column_quo
   }
   score_column <- rlang::ensym(score_column)
-
   ties_method <- rlang::arg_match(ties_method)
+  self_ranking_quo <- rlang::enquo(self_ranking)
+  if (!rlang::quo_is_null(self_ranking_quo)) {
+    self_ranking <- rlang::ensym(self_ranking)
+  }
 
   # check if all .ordering_X columns exist
   ordering_columns <- purrr::map(

R/mtscr_prepare.R

@@ -13,8 +13,16 @@
 #' @param minimal Logical, append columns to df (`FALSE`) or return only `id`, `item`,
 #'     and the new columns (`TRUE`).
 #' @param ties_method Character string specifying how ties are treated when
-#'     ordering. Can be `"average"` (better for continous scores like semantic
+#'     ordering. Can be `"average"` (better for continuous scores like semantic
 #'     distance) or `"random"` (default, better for ratings). See [rank()] for details.
+#' @param self_ranking Name of the column containing answers' self-ranking.
+#'     Provide if model should be based on top answers self-chosen by the participant.
+#'     Every item should have its own ranks. Preferably it should be a complete ranking
+#'     (each answer with its own relative rank) starting with 1 for the best answer.
+#'     Otherwise the top answers should have a value of 1, and the other answers should
+#'     have a value of 0. In that case, the `top` argument doesn't change anything
+#'     and should be left as `top = 1`. `ties_method` is not used if `self_ranking`
+#'     was provided.
 #'
 #' @return The input data frame with additional columns:
 #'     \describe{
@@ -32,7 +40,7 @@
 #' data("mtscr_creativity", package = "mtscr")
 #' # Indicators for top 1 and top 2 answers
 #' mtscr_prepare(mtscr_creativity, id, item, SemDis_MEAN, top = 1:2, minimal = TRUE)
-mtscr_prepare <- function(df, id_column, item_column = NULL, score_column, top = 1, minimal = FALSE, ties_method = c("random", "average")) {
+mtscr_prepare <- function(df, id_column, item_column = NULL, score_column, top = 1, minimal = FALSE, ties_method = c("random", "average"), self_ranking = NULL) {
   id_column <- rlang::ensym(id_column)
   item_column_quo <- rlang::enquo(item_column)
   if (!rlang::quo_is_null(item_column_quo)) {
@@ -41,8 +49,11 @@ mtscr_prepare <- function(df, id_column, item_column = NULL, score_column, top =
     item_column <- item_column_quo
   }
   score_column <- rlang::ensym(score_column)
-
   ties_method <- rlang::arg_match(ties_method)
+  self_ranking_quo <- rlang::enquo(self_ranking)
+  if (!rlang::quo_is_null(self_ranking_quo)) {
+    self_ranking <- rlang::ensym(self_ranking)
+  }
 
   # check if df is a data frame
   if (!is.data.frame(df)) {
@@ -145,6 +156,16 @@ mtscr_prepare <- function(df, id_column, item_column = NULL, score_column, top =
     df <- dplyr::ungroup(df)
   }
 
+  # check if self_ranking contains only positive values
+  if (!rlang::quo_is_null(self_ranking_quo) && any(df[[rlang::as_name(self_ranking)]] <= 0)) {
+    cli::cli_abort(
+      c(
+        "{.var self_ranking must contain only positive values.",
+        "i" = "Check if the best answers have rank 1."
+      )
+    )
+  }
+
   # Remove NA scores if present
   if (any(is.na(df[[rlang::as_name(score_column)]]))) {
     cli::cli_inform(
@@ -171,13 +192,20 @@ mtscr_prepare <- function(df, id_column, item_column = NULL, score_column, top =
   df <- df |>
     dplyr::arrange({{ id_column }}, {{ item_column }}, dplyr::desc(.data$.z_score))
 
-  base_cols <- df |>
-    dplyr::mutate(
-      .ordering = rank(
-        -.data$.z_score, # minus for descending order
-        ties.method = ties_method
-      ) - 1 # -1 to start with 0
-    )
+  if (rlang::quo_is_null(self_ranking_quo)) {
+    base_cols <- df |>
+      dplyr::mutate(
+        .ordering = rank(
+          -.data$.z_score, # minus for descending order
+          ties.method = ties_method
+        ) - 1 # -1 to start with 0
+      )
+  } else {
+    base_cols <- df |>
+      dplyr::mutate(
+        .ordering = abs(!!self_ranking - 1)
+      )
+  }
 
   top <- as.list(top)
 
@@ -199,7 +227,7 @@ mtscr_prepare <- function(df, id_column, item_column = NULL, score_column, top =
 
   if (minimal) {
     df <- df |>
-        dplyr::select({{ id_column }}, {{ item_column }}, ".z_score", dplyr::starts_with(".ordering"))
+      dplyr::select({{ id_column }}, {{ item_column }}, ".z_score", dplyr::starts_with(".ordering"))
   }
 
   return(df)

R/mtscr_score.R

@@ -22,7 +22,7 @@
 #'
 #' # add scores to the original data frame
 #' mtscr_score(mtscr_creativity, id, item, SemDis_MEAN, format = "full")
-mtscr_score <- function(df, id_column, item_column = NULL, score_column, top = 1, format = c("minimal", "full"), ties_method = c("random", "average")) {
+mtscr_score <- function(df, id_column, item_column = NULL, score_column, top = 1, format = c("minimal", "full"), ties_method = c("random", "average"), self_ranking = NULL) {
   id_column <- rlang::ensym(id_column)
   item_column_quo <- enquo(item_column)
   if (!rlang::quo_is_null(item_column_quo)) {
@@ -33,6 +33,10 @@ mtscr_score <- function(df, id_column, item_column = NULL, score_column, top = 1
   score_column <- rlang::ensym(score_column)
   format <- rlang::arg_match(format)
   ties_method <- rlang::arg_match(ties_method)
+  self_ranking_quo <- rlang::enquo(self_ranking)
+  if (!rlang::quo_is_null(self_ranking_quo)) {
+    self_ranking <- rlang::ensym(self_ranking)
+  }
   df_original <- df
 
   # prepare

inst/GUI/app.R

@@ -82,11 +82,33 @@ server <- function(input, output, session) {
         )
       )),
       selectInput("ties_method", "Select ties method", choices = c("random (better for ratings)", "average (better for continous scores)")),
+      actionButton("self_ranking_info", "What is self-ranking?"),
+      selectInput(
+        "self_ranking",
+        "Column with self-ranking:",
+        choices = c(
+          "no self-ranking",
+          colnames(dplyr::select(
+            imported$data(),
+            dplyr::where(is.numeric)
+          ))
+        )
+      ),
       sliderInput("top", "Max number of top answers to be included:", value = 1, min = 1, max = 10),
       actionButton("generate_model", "Generate model →")
     )
   })
 
+  ## self_ranking info box ----
+
+  observeEvent(input$self_ranking_info, {
+    shinyWidgets::show_alert(
+      title = NULL,
+      text = "Name of the column containing answers' self-ranking. Provide if model should be based on top answers self-chosen by the participant. Every item should have its own ranks. Preferably it should be a complete ranking (each answer with its own relative rank) starting with 1 for the best answer. Otherwise the top answers should have a value of 1, and the other answers should have a value of 0. In that case, the Top answers argument doesn't change anything so leave the slider at 1. Ties method is not used if self-ranking was provided.",
+      type = "info"
+    )
+  })
+
   ## Generate model button ----
   observeEvent(input$generate_model, {
     ### Create model ----
@@ -100,7 +122,12 @@ server <- function(input, output, session) {
     score_col <- input$score_column
     ties_method <- ifelse(input$ties_method == "random (better for ratings)", "random", "average")
     top <- seq(1, input$top)
-    model <- mtscr::mtscr_model(data, !!id_col, !!item_col, !!score_col, top = top, ties_method = ties_method)
+    if (input$self_ranking == "no self-ranking") {
+      item_col <- NULL
+    } else {
+      item_col <- input$self_ranking
+    }
+    model <- mtscr::mtscr_model(data, !!id_col, !!item_col, !!score_col, top = top, ties_method = ties_method, self_ranking = self_ranking)
     if (length(top) == 1) {
       model <- list(model)
     }
@@ -111,8 +138,8 @@ server <- function(input, output, session) {
     output$models_summary <- renderTable(models_summary)
 
     ### Make UI for scored data ----
-    scored_data <- mtscr::mtscr_score(data, !!id_col, !!item_col, !!score_col, top = top, format = "minimal", ties_method = ties_method)
-    scored_data_whole <- mtscr::mtscr_score(data, !!id_col, !!item_col, !!score_col, top = top, format = "full", ties_method = ties_method)
+    scored_data <- mtscr::mtscr_score(data, !!id_col, !!item_col, !!score_col, top = top, format = "minimal", ties_method = ties_method, self_ranking = self_ranking)
+    scored_data_whole <- mtscr::mtscr_score(data, !!id_col, !!item_col, !!score_col, top = top, format = "full", ties_method = ties_method, self_ranking = self_ranking)
     output$scored_data_header <- renderUI(tags$b("Scored data:"))
     output$scored_data <- DT::renderDataTable(
       scored_data,

tests/testthat/test-mtscr_app.R

@@ -5,7 +5,7 @@ testthat::test_that("mtscr_app runs", {
 })
 
 # Test that all needed packages are checked
-needed_packages <- c("DT", "broom.mixed", "datamods", "writexl")
+needed_packages <- c("DT", "datamods", "writexl", "shinyWidgets")
 returned_message <- mtscr_app(debug_mode = 1)
 
 testthat::test_that("all needed packages are checked", {