Merge pull request #21 from ljwoodley/add_field_type_slider_support

Add field type slider support

NAMESPACE

@@ -4,6 +4,8 @@ export(get_long_categorical_field_response_values)
 export(get_long_categorical_field_responses)
 export(get_long_notes_field_values)
 export(get_long_notes_fields)
+export(get_long_slider_field_values)
+export(get_long_slider_fields)
 export(get_long_text_field_values)
 export(get_long_text_fields)
 export(get_one_rectangle_of_values)

NEWS.md

@@ -1,5 +1,4 @@
-# redcapfiller (0.1.0.9001)
+# redcapfiller 0.1.0.9001 (released TBD)
 
-* Supports filling of checkbox, dropdown, radio, yes/no, True/False and unvalidated text fields on classic projects.
-* Provides a proof_of_concept.R script with write-back to a demonstration project and properly managed secrets.
-
+- Supports filling of checkbox, dropdown, radio, yes/no, True/False, sliders and unvalidated text fields on classic projects.
+- Provides a proof_of_concept.R script with write-back to a demonstration project and properly managed secrets.

R/get_long_slider_field_values.R

@@ -0,0 +1,34 @@
+#' @title generate slider field values
+#' @description
+#' Provide a set of values for each slider field in
+#' `long_slider_values`
+#'
+#' @param long_slider_values a long data set of slider values and weights.
+#'
+#' @return a tall dataframe of slider values with one row for each field
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' get_long_slider_field_values(long_slider_values)
+#' }
+get_long_slider_field_values <- function(long_slider_values) {
+
+  result <- long_slider_values |>
+    dplyr::filter(.data$field_type == "slider") |>
+    dplyr::mutate(
+      response_code = round(stats::rnorm(n = length(.data$mean), mean = .data$mean, sd = .data$sd)),
+      response_code = as.character(ifelse(
+        .data$response_code < dplyr::coalesce(as.numeric(.data$text_validation_min), 0) |
+          .data$response_code > dplyr::coalesce(as.numeric(.data$text_validation_max), 100) ,
+        NA,
+        .data$response_code)
+      )
+    ) |>
+    dplyr::group_by(.data$field_name) |>
+    dplyr::slice_sample(n = 1, weight_by = .data$weight) |>
+    dplyr::ungroup() |>
+    dplyr::select("field_name", value = "response_code")
+
+  return(result)
+}

R/get_long_slider_fields.R

@@ -0,0 +1,64 @@
+#' @title Get slider field ranges from a REDCap data dictionary
+#'
+#' @description
+#' Given a REDCap data dictionary, enumerate range of values for every slider field in that data dictionary
+#'
+#' @param metadata A REDCap data dictionary
+#'
+#' @returns a dataframe with these columns
+#' \describe{
+#'   \item{field_name}{REDCap field name}
+#'   \item{form_name}{REDCap form name}
+#'   \item{field_type}{REDCap field type}
+#'   \item{select_choices_or_calculations}{RedCap select_choices_or_calculations field}
+#'   \item{text_validation_min}{REDCap text validation min}
+#'   \item{text_validation_max}{REDCap text validation max}
+#'   \item{mean}{mean of data to be generated}
+#'   \item{sd}{standard deviation of data to be generated}
+#'
+#' }
+#' @export
+#'
+#' @examples
+#' \dontrun{
+#' long_slider_fields <-
+#'   get_long_slider_fields(metadata_to_populate)
+#' }
+get_long_slider_fields <- function(metadata) {
+  long_slider_values <- metadata |>
+    # include only slider field types
+    dplyr::filter(.data$field_type == "slider") |>
+    dplyr::group_by(.data$field_name) |>
+    dplyr::mutate(
+      text_validation_max = dplyr::if_else(
+        is.na(.data$text_validation_max),
+        "100",
+        as.character(.data$text_validation_max)
+      ),
+      text_validation_min = dplyr::if_else(
+        is.na(.data$text_validation_min),
+        "0",
+        as.character(.data$text_validation_min)
+      )
+    ) |>
+    # narrow our focus to the required columns
+    dplyr::select(
+      c(
+        "field_name",
+        "form_name",
+        "field_type",
+        "select_choices_or_calculations",
+        "text_validation_min",
+        "text_validation_max"
+      )
+    ) |>
+    dplyr::group_by(.data$field_type) |>
+    dplyr::mutate(
+      weight = 100,
+      mean = (as.numeric(.data$text_validation_min) + as.numeric(.data$text_validation_max)) / 2,
+      sd = (as.numeric(.data$text_validation_max) - as.numeric(.data$text_validation_min)) / 6
+    ) |>
+    dplyr::ungroup()
+
+  return(long_slider_values)
+}

R/get_one_rectangle_of_values.R

@@ -30,6 +30,7 @@ get_one_rectangle_of_values <- function(
   value_getter_functions <- c(
     "get_long_categorical_field_response_values",
     "get_long_text_field_values",
+    "get_long_slider_field_values",
     "get_long_notes_field_values"
   )
 

proof_of_concept.R

@@ -46,7 +46,8 @@ field_types_we_know_how_to_fill <- c(
   "radio",
   "text",
   "yesno",
-  "truefalse"
+  "truefalse",
+  "slider"
 )
 
 metadata_to_populate <-
@@ -75,7 +76,7 @@ read_result <- REDCapR::redcap_read(
   redcap_uri = credentials$redcap_uri
 )
 
-if (read_result$success) {
+if (nrow(read_result$data) > 0) {
   max_existing_id <- max(read_result$data$record_id)
 } else {
   max_existing_id <- 0
@@ -89,11 +90,13 @@ record_ids <- seq(first_id, first_id + number_of_records_to_populate)
 # get the categorical field responses in a long table and populate them
 long_categorical_field_responses <- get_long_categorical_field_responses(metadata_to_populate)
 long_text_fields <- get_long_text_fields(metadata_to_populate)
+long_slider_fields <- get_long_slider_fields(metadata_to_populate)
 long_notes_fields <- get_long_notes_fields(metadata_to_populate)
 
 long_fields_and_responses <- bind_rows(
   long_categorical_field_responses,
   long_text_fields,
+  long_slider_fields,
   long_notes_fields
 )
 

tests/testthat/get_long_slider_field_values/make_test_data.R

@@ -0,0 +1,6 @@
+metadata_file <- testthat::test_path("get_long_slider_field_values", "metadata.csv")
+metadata <- readr::read_csv(metadata_file)
+
+long_slider_fields <- get_long_slider_fields(metadata)
+long_slider_fields |>
+  saveRDS(testthat::test_path("get_long_slider_field_values", "input.rds"))

tests/testthat/get_long_text_fields/metadata.csv → tests/testthat/get_long_slider_field_values/metadata.csv

@@ -1,16 +1,18 @@
 field_name,form_name,section_header,field_type,field_label,select_choices_or_calculations,field_note,text_validation_type_or_show_slider_number,text_validation_min,text_validation_max,identifier,branching_logic,required_field,custom_alignment,question_number,matrix_group_name,matrix_ranking,field_annotation
 record_id,form_1,,text,Record ID,,,,,,,,,,,,,
 f_calculated,form_1,Menu of Field Types,calc,Calculated Field,3+4,,,,,,,,,,,,
-f_checkbox,form_1,,checkbox,Checkboxes,"0, Zero|1, One|2, Two",,,,,,,,,,,,
+f_checkbox,form_1,,checkbox,Checkboxes,"0, Zero | 1, One | 2, Two",,,,,,,,,,,,
 f_descriptive,form_1,,descriptive,Descriptive Text,,,,,,,,,,,,,
-f_dropdown,form_1,,dropdown,Dropdown,"0, Zero|1, One|2, Two",,,,,,,,,,,,
+f_dropdown,form_1,,dropdown,Dropdown,"0, Zero | 1, One | 2, Two",,,,,,,,,,,,
 f_file_upload,form_1,,file,File Upload,,,,,,,,,,,,,
 f_notes,form_1,,notes,Notes Box,,,,,,,,,,,,,
-f_radio,form_1,,radio,Radio Buttons,"0, Zero|1, One|2, Two",,,,,,,,,,,,
+f_radio,form_1,,radio,Radio Buttons,"0, Zero | 1, One | 2, Two",,,,,,,,,,,,
 f_signature,form_1,,file,Signature,,,signature,,,,,,,,,,
-f_slider,form_1,,slider,Slider,5 |  | 95,,,,33,,,,RH,,,,
-f_slider2,form_1,,slider,Slider 2,20 | 30 | 60,,,,11,,,,RH,,,,
-f_sql,form_1,,sql,Dynamic SQL,,,,,,,,,RH,,,,
+f_slider1,form_1,,slider,Slider1,-1 | 50 | 101,,,-1,101,,,,RH,,,,
+f_slider2,form_1,,slider,Slider2,-1 | 50 | 101,,,,,,,,RH,,,,
+f_slider3,form_1,,slider,Slider3,25 | 50 | 75,,,25,75,,,,RH,,,,
+f_slider4,form_1,,slider,Slider4,1 | 5 | 10,,,0,10,,,,RH,,,,
+f_sql,form_1,,sql,Dynamic SQL,SELECT 1 as one;,,,,,,,,RH,,,,
 f_text,form_1,,text,text box (no validation),,,,,,,,,,,,,
 f_true_false,form_1,,truefalse,True -False,,,,,,,,,,,,,
 f_yes_no,form_1,,yesno,Yes - No,,,,,,,,,,,,,

tests/testthat/get_long_categorical_field_responses/metadata.csv → tests/testthat/shared_testdata/metadata.csv

@@ -1,16 +1,15 @@
 field_name,form_name,section_header,field_type,field_label,select_choices_or_calculations,field_note,text_validation_type_or_show_slider_number,text_validation_min,text_validation_max,identifier,branching_logic,required_field,custom_alignment,question_number,matrix_group_name,matrix_ranking,field_annotation
 record_id,form_1,,text,Record ID,,,,,,,,,,,,,
 f_calculated,form_1,Menu of Field Types,calc,Calculated Field,3+4,,,,,,,,,,,,
-f_checkbox,form_1,,checkbox,Checkboxes,"0, Zero|1, One|2, Two",,,,,,,,,,,,
+f_checkbox,form_1,,checkbox,Checkboxes,"0, Zero | 1, One | 2, Two",,,,,,,,,,,,
 f_descriptive,form_1,,descriptive,Descriptive Text,,,,,,,,,,,,,
-f_dropdown,form_1,,dropdown,Dropdown,"0, Zero|1, One|2, Two",,,,,,,,,,,,
+f_dropdown,form_1,,dropdown,Dropdown,"0, Zero | 1, One | 2, Two",,,,,,,,,,,,
 f_file_upload,form_1,,file,File Upload,,,,,,,,,,,,,
 f_notes,form_1,,notes,Notes Box,,,,,,,,,,,,,
-f_radio,form_1,,radio,Radio Buttons,"0, Zero|1, One|2, Two",,,,,,,,,,,,
+f_radio,form_1,,radio,Radio Buttons,"0, Zero | 1, One | 2, Two",,,,,,,,,,,,
 f_signature,form_1,,file,Signature,,,signature,,,,,,,,,,
-f_slider,form_1,,slider,Slider,5 |  | 95,,,,33,,,,RH,,,,
-f_slider2,form_1,,slider,Slider 2,20 | 30 | 60,,,,11,,,,RH,,,,
-f_sql,form_1,,sql,Dynamic SQL,,,,,,,,,RH,,,,
+f_slider,form_1,,slider,Slider,-1 | 50 | 101,,,-1,101,,,,RH,,,,
+f_sql,form_1,,sql,Dynamic SQL,SELECT 1 as one;,,,,,,,,RH,,,,
 f_text,form_1,,text,text box (no validation),,,,,,,,,,,,,
 f_true_false,form_1,,truefalse,True -False,,,,,,,,,,,,,
 f_yes_no,form_1,,yesno,Yes - No,,,,,,,,,,,,,

tests/testthat/test-get_long_categorical_field_responses.R

@@ -1,4 +1,4 @@
-metadata_file <- testthat::test_path("get_long_categorical_field_responses", "metadata.csv")
+metadata_file <- testthat::test_path("shared_testdata", "metadata.csv")
 metadata <- readr::read_csv(metadata_file)
 
 output <- get_long_categorical_field_responses(metadata)
@@ -54,3 +54,4 @@ testthat::test_that("get_long_categorical_field_responses: yesno are 1 and 0", {
    dplyr::pull(response_code),
  c("1", "0"))
 })
+

tests/testthat/test-get_long_slider_field_values.R

@@ -0,0 +1,32 @@
+long_slider_fields <- readRDS(
+  testthat::test_path("get_long_slider_field_values", "input.rds")
+)
+
+output <- get_long_slider_field_values(long_slider_fields)
+
+testthat::test_that("get_long_slider_field_values returns the correct df with values within the slider ranges", {
+  slider_bounds <- long_slider_fields |>
+    dplyr::select(field_name, text_validation_min, text_validation_max) |>
+    dplyr::group_by(field_name) |>
+    dplyr::summarise(
+      text_validation_min = min(text_validation_min),
+      text_validation_max = max(text_validation_max)
+    )
+
+  result <- output %>%
+    dplyr::left_join(slider_bounds, by = "field_name") |>
+    dplyr::summarise(all_within_range = all(dplyr::between(
+      as.numeric(value),
+      as.numeric(text_validation_min),
+      as.numeric(text_validation_max)
+    ), na.rm = TRUE))
+
+  testthat::expect_true(result$all_within_range)
+})
+
+testthat::test_that("get_long_slider_field_values returns a unique number for each slider", {
+  testthat::expect_equal(
+    output |> dplyr::distinct(value) |> nrow(),
+    output |> nrow()
+  )
+})

tests/testthat/test-get_long_slider_fields.R

@@ -0,0 +1,33 @@
+metadata_file <- testthat::test_path("shared_testdata", "metadata.csv")
+metadata <- readr::read_csv(metadata_file)
+
+output <- get_long_slider_fields(metadata)
+
+testthat::test_that("get_long_slider_fields: processes sliders", {
+  testthat::expect_equal(
+    output |>
+      dplyr::distinct(field_type) |>
+      dplyr::arrange(field_type) |>
+      dplyr::pull(field_type),
+    "slider"
+  )
+})
+
+testthat::test_that("get_long_slider_fields values are distinct within each field", {
+  duplicate_values <- output %>%
+    dplyr::group_by(field_name) %>%
+    dplyr::summarise(duplicates = sum(duplicated(select_choices_or_calculations))) %>%
+    dplyr::pull(duplicates)
+
+  testthat::expect_true(all(duplicate_values == 0), "There are duplicate values within groups")
+})
+
+testthat::test_that("get_long_slider_fields weights are balanced", {
+  testthat::expect_true(output |>
+                          dplyr::group_by(field_name) |>
+                          dplyr::summarise(balanced = (min(weight) == max(weight))) |>
+                          dplyr::ungroup() |>
+                          dplyr::distinct(balanced) |>
+                          dplyr::pull(balanced))
+})
+

tests/testthat/test-get_long_text_fields.R

@@ -1,4 +1,4 @@
-metadata_file <- testthat::test_path("get_long_text_fields", "metadata.csv")
+metadata_file <- testthat::test_path("shared_testdata", "metadata.csv")
 metadata <- readr::read_csv(metadata_file)
 
 output <- get_long_text_fields(metadata)
@@ -30,3 +30,4 @@ testthat::test_that("get_long_text_fields: weights are balanced", {
     dplyr::distinct(balanced) |>
     dplyr::pull(balanced))
 })
+