Create function to plot sampled categorical data

DESCRIPTION

@@ -30,6 +30,7 @@ Imports:
     miceadds,
     openxlsx,
     rlang,
+    scales,
     stats,
     stringr,
     tibble,

NAMESPACE

@@ -1,5 +1,6 @@
 # Generated by roxygen2: do not edit by hand
 
+S3method(plot,cat_sample)
 S3method(print,elic_cat)
 S3method(print,elic_cont)
 export(cat_add_data)
@@ -37,13 +38,19 @@ importFrom(ggplot2,aes)
 importFrom(ggplot2,element_blank)
 importFrom(ggplot2,element_line)
 importFrom(ggplot2,element_text)
+importFrom(ggplot2,expansion)
+importFrom(ggplot2,facet_wrap)
 importFrom(ggplot2,geom_errorbar)
 importFrom(ggplot2,geom_point)
+importFrom(ggplot2,geom_violin)
 importFrom(ggplot2,ggplot)
 importFrom(ggplot2,labs)
 importFrom(ggplot2,scale_colour_manual)
+importFrom(ggplot2,scale_fill_manual)
 importFrom(ggplot2,scale_x_continuous)
+importFrom(ggplot2,scale_y_continuous)
 importFrom(ggplot2,scale_y_discrete)
+importFrom(ggplot2,stat_summary)
 importFrom(ggplot2,theme)
 importFrom(ggplot2,theme_bw)
 importFrom(ggplot2,unit)
@@ -52,12 +59,14 @@ importFrom(miceadds,sumpreserving.rounding)
 importFrom(openxlsx,read.xlsx)
 importFrom(rlang,.data)
 importFrom(rlang,caller_env)
+importFrom(scales,hue_pal)
 importFrom(stats,median)
 importFrom(stats,na.omit)
 importFrom(stats,setNames)
 importFrom(stringr,str_split_1)
 importFrom(tibble,as_tibble)
 importFrom(tibble,remove_rownames)
+importFrom(tidyr,pivot_longer)
 importFrom(tidyr,pivot_wider)
 importFrom(tools,file_ext)
 importFrom(utils,read.csv)

R/cat_get_data.R

@@ -76,7 +76,7 @@ cat_get_data <- function(x,
       error <- "{cli::qty(diff)} Site{?s} {.val {diff}} not available in \\
                 mechanism {.val {mechanism}}."
       info <- "Available site{?s}: {.val {available_sites}}."
-      cli::cli_abort(c("Invalid value for {.arg {site}}:",
+      cli::cli_abort(c("Invalid value for argument {.arg site}:",
                        "x" = error,
                        "i" = info))
     }

R/cat_sample_data.R

@@ -31,7 +31,7 @@
 #' to all votes for this level.
 #'
 #' @return An [`tibble`][tibble::tibble] with the sampled data. This object has
-#' the additional class `elic_cat_sample` used to implement the plotting method.
+#' the additional class `cat_sample` used to implement the plotting method.
 #' @export
 #'
 #' @family cat data helpers
@@ -105,7 +105,10 @@ cat_sample_data <- function(x,
   }
 
   # Prepend new class
-  class(out) <- c("elic_cat_sample", class(out))
+  class(out) <- c("cat_sample", class(out))
+
+  # Add attribute with the name of the mechanism
+  attr(out, "mechanism") <- mechanism
 
   out
 }

R/cont_add_data.R

@@ -1,3 +1,8 @@
+# List with column labels
+var_labels <- list("1p" = "best",
+                   "3p" = c("min", "max", "best"),
+                   "4p" = c("min", "max", "best", "conf"))
+
 #' Add data
 #'
 #' @description

R/cont_plot.R

@@ -114,7 +114,8 @@ cont_plot <- function(x,
   check_var_in_obj(x, var)
 
   if (is.null(theme)) {
-    theme <- elic_theme(family = family)
+    theme <- elic_theme(family = family) +
+      cont_theme()
   }
 
   data <- cont_get_data(x, round = round, var = var) |>
@@ -429,36 +430,19 @@ check_truth <- function(x, elic_type) {
 
 # Plot theme----
 
-
-#' Elic theme
+#'Theme
 #'
-#' Custom theme for elicitation plots.
+#' Custom theme for continuous data.
 #'
 #' @return A [`theme`][`ggplot2::theme`] function.
 #' @noRd
 #'
 #' @author Sergio Vignali and Maude Vernet
-elic_theme <- function(family = "sans") {
-  ggplot2::theme_bw() +
-    ggplot2::theme(legend.position = "none",
-                   plot.title = ggplot2::element_text(size = 16,
-                                                      face = "bold",
-                                                      hjust = 0.5,
-                                                      family = family),
-                   panel.grid.major.x = ggplot2::element_line(colour = "black",
-                                                              linetype = 8,
-                                                              linewidth = 0.1),
-                   panel.grid.major.y = ggplot2::element_blank(),
-                   panel.grid.minor = ggplot2::element_blank(),
-                   axis.title.y = ggplot2::element_text(size = 16,
-                                                        color = "black",
-                                                        family = family),
-                   axis.title.x = ggplot2::element_text(vjust = -1.2,
-                                                        size = 16,
-                                                        color = "black",
-                                                        family = family),
-                   axis.ticks.length = ggplot2::unit(0.5, units = "mm"),
-                   axis.text = ggplot2::element_text(size = 14,
-                                                     family = family),
-                   plot.margin = ggplot2::unit(c(5, 10, 5, 5), units = "mm"))
+cont_theme <- function() {
+  ggplot2::theme(panel.grid.major.x = ggplot2::element_line(colour = "black",
+                                                            linetype = 8,
+                                                            linewidth = 0.1),
+                 panel.grid.major.y = ggplot2::element_blank(),
+                 axis.ticks.length = ggplot2::unit(0.5, units = "mm"),
+                 legend.position = "none")
 }

R/elicitr-package.R

@@ -29,13 +29,19 @@
 #' @importFrom ggplot2 element_blank
 #' @importFrom ggplot2 element_line
 #' @importFrom ggplot2 element_text
+#' @importFrom ggplot2 expansion
+#' @importFrom ggplot2 facet_wrap
 #' @importFrom ggplot2 geom_errorbar
 #' @importFrom ggplot2 geom_point
+#' @importFrom ggplot2 geom_violin
 #' @importFrom ggplot2 ggplot
 #' @importFrom ggplot2 labs
 #' @importFrom ggplot2 scale_colour_manual
+#' @importFrom ggplot2 scale_fill_manual
 #' @importFrom ggplot2 scale_x_continuous
+#' @importFrom ggplot2 scale_y_continuous
 #' @importFrom ggplot2 scale_y_discrete
+#' @importFrom ggplot2 stat_summary
 #' @importFrom ggplot2 theme
 #' @importFrom ggplot2 theme_bw
 #' @importFrom ggplot2 unit
@@ -44,12 +50,14 @@
 #' @importFrom openxlsx read.xlsx
 #' @importFrom rlang .data
 #' @importFrom rlang caller_env
+#' @importFrom scales hue_pal
 #' @importFrom stats median
 #' @importFrom stats na.omit
 #' @importFrom stats setNames
 #' @importFrom stringr str_split_1
 #' @importFrom tibble as_tibble
 #' @importFrom tibble remove_rownames
+#' @importFrom tidyr pivot_longer
 #' @importFrom tidyr pivot_wider
 #' @importFrom tools file_ext
 #' @importFrom utils read.csv

R/plot_cat_sample.R

@@ -0,0 +1,170 @@
+#' Plot categorical samples
+#'
+#' The function aggregates and plots the categorical samples as violin plot.
+#'
+#' @param x an object of class `cat_sample` created by the function
+#' [cat_sample_data].
+#' @inheritParams cat_get_data
+#' @param title character string with the title of the plot. If `NULL`, the
+#' title will be the topic name.
+#' @param ylab character string with the label of the y-axis.
+#' @param colours vector of colours to use for the categories.
+#' @param family character string with the font family to use in the plot.
+#' @param theme a [`theme`][`ggplot2::theme`] function to overwrite the default
+#' theme.
+#'
+#' @details If a `theme` is provided, the `family` argument is ignored.
+#'
+#' @returns Invisibly a [`ggplot`][`ggplot2::ggplot`] object.
+#' @export
+#'
+#' @author Sergio Vignali and Maude Vernet
+#'
+#' @examples
+#' # Create the elic_cat object for an elicitation process with three
+#' # mechanisms, four sites, five levels and a maximum of six experts per
+#' # mechanism
+#' my_levels <- c("level_1", "level_2", "level_3", "level_4", "level_5")
+#' my_sites <- c("site_1", "site_2", "site_3", "site_4")
+#' my_mechanisms <- c("mechanism_1", "mechanism_2", "mechanism_3")
+#' my_elicit <- cat_start(levels = my_levels,
+#'                        sites = my_sites,
+#'                        experts = 6,
+#'                        mechanisms = my_mechanisms) |>
+#'   cat_add_data(data_source = mechanism_1, mechanism = "mechanism_1") |>
+#'   cat_add_data(data_source = mechanism_2, mechanism = "mechanism_2") |>
+#'   cat_add_data(data_source = mechanism_3, mechanism = "mechanism_3")
+#'
+#' # Sample data from Mechanism 1 for all sites using the basic method
+#' samp <- cat_sample_data(my_elicit,
+#'                         method = "basic",
+#'                         mechanism = "mechanism_1")
+#'
+#' # Plot the sampled data for all sites
+#' plot(samp)
+#'
+#' # Plot the sampled data for site 1
+#' plot(samp, site = "site_1")
+#'
+#' # Plot the sampled data for site 1 and 3
+#' plot(samp, site = c("site_1", "site_3"))
+#'
+#' # Provide custom colours
+#' plot(samp, colours = c("steelblue4", "darkcyan", "chocolate1",
+#'                        "chocolate3", "orangered4"))
+#'
+#' # Overwrite the default theme
+#' plot(samp, theme = ggplot2::theme_minimal())
+plot.cat_sample <- function(x,
+                            ...,
+                            site = "all",
+                            title = NULL,
+                            ylab = "Probabolity",
+                            colours = NULL,
+                            family = "sans",
+                            theme = NULL) {
+
+  if (any(site != "all")) {
+
+    # Check if site is not among the available sites in the data
+    available_sites <- unique(x[["site"]])
+    diff <- setdiff(site, available_sites)
+
+    if (length(diff) > 0) {
+      error <- "{cli::qty(diff)} Site{?s} {.val {diff}} not available in \\
+               the sampled data."
+      info <- "Available site{?s}: {.val {available_sites}}."
+      cli::cli_abort(c("Invalid value for argument {.arg site}:",
+                       "x" = error,
+                       "i" = info))
+    }
+
+    # Avoid overwrite dplyr variable
+    vals <- site
+    x <- x |>
+      dplyr::filter(.data[["site"]] %in% vals) |>
+      dplyr::mutate("site" = factor(.data[["site"]], levels = vals))
+  }
+
+  if (is.null(title)) {
+    title <- attr(x, "mechanism")
+  }
+
+  x <- x |>
+    tidyr::pivot_longer(cols = -c("id", "site"),
+                        names_to = "level",
+                        values_to = "prob") |>
+    dplyr::mutate("level" = factor(.data[["level"]],
+                                   levels = unique(.data[["level"]])))
+
+  if (is.null(colours)) {
+    colours <- scales::hue_pal()(length(unique(x[["level"]])))
+  } else {
+
+    n_level <- length(unique(x[["level"]]))
+    if (length(colours) != n_level) {
+
+      error <- "The number of colours provided does not match the number \\
+                of levels."
+      cli::cli_abort(c("Invalid value for argument {.arg colours}:",
+                       "x" = error,
+                       "i" = "Please provide a vector with {.val {n_level}} \\
+                              colours."))
+    }
+  }
+
+  if (is.null(theme)) {
+    theme <- elic_theme(family = family) +
+      cat_sample_theme()
+  }
+
+  p <- ggplot2::ggplot(x) +
+    ggplot2::geom_violin(mapping = ggplot2::aes(x = .data[["level"]],
+                                                y = .data[["prob"]],
+                                                fill = .data[["level"]]),
+                         color = "black",
+                         alpha = 0.8,
+                         scale = "width",
+                         linewidth = 0.2,
+                         draw_quantiles = c(0.25, 0.75),
+                         key_glyph = "dotplot") +
+    ggplot2::stat_summary(mapping = ggplot2::aes(x = .data[["level"]],
+                                                 y = .data[["prob"]]),
+                          fun = mean,
+                          geom = "point",
+                          color = "black",
+                          size = 0.8) +
+    ggplot2::labs(title = title,
+                  y = ylab) +
+    ggplot2::facet_wrap("site") +
+    ggplot2::scale_fill_manual(values = colours) +
+    ggplot2::scale_y_continuous(limits = c(0, 1),
+                                expand = ggplot2::expansion(mult = c(0,
+                                                                     0.04))) +
+    theme
+
+  p
+}
+
+# Plot theme----
+
+#'Theme
+#'
+#' Custom theme for categorical samples.
+#'
+#' @return A [`theme`][`ggplot2::theme`] function.
+#' @noRd
+#'
+#' @author Sergio Vignali and Maude Vernet
+cat_sample_theme <- function() {
+  ggplot2::theme(axis.text.x = ggplot2::element_blank(),
+                 axis.ticks = ggplot2::element_blank(),
+                 axis.title.x = ggplot2::element_blank(),
+                 panel.grid.major.x = ggplot2::element_blank(),
+                 panel.grid.major.y = ggplot2::element_line(colour = "black",
+                                                            linetype = 8,
+                                                            linewidth = 0.1),
+                 legend.position = "bottom",
+                 legend.key.size = ggplot2::unit(1.5, "line"),
+                 legend.title = ggplot2::element_blank())
+}

R/utils.R

@@ -591,3 +591,32 @@ hash_names <- function(x) {
     substr(start = 1,
            stop = 7)
 }
+
+# Theme----
+
+#' Elic theme
+#'
+#' Custom theme for elicitation plots.
+#'
+#' @return A [`theme`][`ggplot2::theme`] function.
+#' @noRd
+#'
+#' @author Sergio Vignali and Maude Vernet
+elic_theme <- function(family = "sans") {
+  ggplot2::theme_bw() +
+    ggplot2::theme(plot.title = ggplot2::element_text(size = 16,
+                                                      face = "bold",
+                                                      hjust = 0.5,
+                                                      family = family),
+                   panel.grid.minor = ggplot2::element_blank(),
+                   axis.title.y = ggplot2::element_text(size = 16,
+                                                        color = "black",
+                                                        family = family),
+                   axis.title.x = ggplot2::element_text(vjust = -1.2,
+                                                        size = 16,
+                                                        color = "black",
+                                                        family = family),
+                   axis.text = ggplot2::element_text(size = 14,
+                                                     family = family),
+                   plot.margin = ggplot2::unit(c(5, 10, 5, 5), units = "mm"))
+}