In unhcr-americas/surveyDesigner: A Shiny App to help in the survey integration process

library(testthat)

# Load already included functions if relevant
pkgload::load_all(export_all = FALSE)
library(readxl)
library(dplyr)
library(purrr)

r6_referential

The filtering of the referential should take in account the order/sequence of questions and modules.

A specific method is implemented to separate our file with begin and end group

#' Referential class is a class to load, check and manipulate the XLSForm 
#' @importFrom R6 R6Class
#' 
#' @export

Referential <- R6::R6Class(classname = "Referential",
                           public = list(
                             #' @description 
                             #' read the xlsx for each sheet and return a named list
                             #' @param path path to the file with the full referential
                             #' 
                             #' @importFrom readxl excel_sheets read_xlsx
                             #' 
                             #' @return named list
                             initialize = function(path){
                               # Define path
                               self$path <- path

                               # Get sheets of xlsx
                               sheets <- names_of_sheet(path)

                               # Read the xlsx file 
                               data <- lapply(
                                 sheets, 
                                 function(x){
                                   read_xlsx(path = path, sheet = x)}) |>
                                      setNames(nm = sheets)
                               # TODO checking survey and other sheets

                               # survey have to be a xlsform

                               if(!contains_groups(data$survey)){
                                 stop("the sheet 'survey' doesn't includes groups - i.e. questions organised as module")
                               }

                               self$data <- data

                               # Get groups 

                               self$get_groups()
                             },
                             #' @field data named list for the referential file
                             data = list(),
                             #' @field by_groups survey modules separated by begin and end to manipulate data
                             by_groups = list(),
                             #' @field path path for the xlsx file
                             path  = character(0),
                             #' @description get data by groups of begin and end
                             get_groups = function(){
                               self$by_groups <- get_groups(self$data$survey)

                               message("result is store in `by_groups` sub-element")
                             }
                           ),
                           private = list(

                           )
)

ref <- Referential$new(
  path = system.file("SurveyDesigner_Referential.xlsx", package = "surveyDesigner") 
)

ref <- Referential$new(
  path = system.file("SurveyDesigner_Referential.xlsx", package = "surveyDesigner") 
)

head(ref$data$survey)

# Example by groups
ref$by_groups$group_intro

test_that("r6_referential works", {
  ref <- Referential$new(
    path = system.file("SurveyDesigner_Referential.xlsx", package = "surveyDesigner") 
  )

  expect_true( inherits(ref, "R6") )

  expect_error(
    Referential$new(
      path = "not_good_sheet.xlsx" 
    )
  )

  expect_error(
    Referential$new(
      path = "wt_xlsform_in_survey.xlsx" 
    )
  )

})

Utils for referential manipulation

survey_designer <- new.env()

assign(
  "names_sheets", 
  c("referential_type",
    "survey",
    "choices",
    "indicator",
    "indicator_survey",
    "indicator_choices",
    "indicator_population",
    "indicator_disaggregation"
  ), 
  envir = survey_designer)


#' Get groups form begin and end into a list with data and information
#' 
#' @param data data from the survey sheet
#'
#' @importFrom purrr map2 set_names map
#' @importFrom dplyr slice filter
#' 
#' @return list
#' 
get_groups <- function(data){
  # only on survey

begin_start <- grep(x = data[["type"]], "begin_")
end_stop <- grep(x = data[["type"]], "end_")



if(length(begin_start) != length(end_stop)){
  stop("Miss one begin or stop in the data")
}

if(!all(begin_start < end_stop)){
  stop("One begin is before a end")
}

by_begin_end <- map2(begin_start, end_stop,
                            function(x,y){

                              data_to_get <- data %>% 
                                slice(x:y)
                              by_groups <- list(data = data_to_get %>%
                                                  filter(!type %in% c("begin_group", "end_group")),
                                                information = data_to_get %>%
                                                  filter(type %in% c("begin_group", "end_group"))
                              )
                              # names(by_groups) <- by_groups[["information"]][["name"]]

                              by_groups
                            }) %>% 
  purrr::set_names(nm = purrr::map(., ~ .x[["information"]][["name"]][1]))

 return(by_begin_end)
}

#' Get choices for one question
#'
#' @param survey data from the choices sheet
#' @param full_name the full name (i.e. concatenating groups) for the variable
#'
#' @importFrom dplyr filter select contains
#'
#' @return a data.frame to join
get_choices_for_question <- function(survey, full_name){
  survey %>% 
    filter(list_name == full_name) %>% 
    select(list_name, name, label)
}

#' function to find if we manipulate a xlsform
#'
#' @param data data of the survey
#'
#' @noRd


contains_groups <- function(data){
  any(grepl(x = data[["type"]], pattern = 'begin_group|begin_repeat|end_group|end_repeat'))
}

#' function to check name of sheets
#'
#' @param path path to the xlsform
#'
#' @noRd
names_of_sheet <- function(path){
  sheets <- excel_sheets(path)
  if(all(sheets == get("names_sheets", envir = survey_designer))){
    return(sheets)
  }else{
    stop("Problem with the name of sheets")
  }
}

data <- ref$data$survey

begin_start <- grep(x = , "begin_")
end_stop <- grep(x = data[["type"]], "end_")



if(length(begin_start) != length(end_stop)){
  stop("Miss one begin or stop in the data")
}

if(!all(begin_start < end_stop)){
  stop("One begin is before a end")
}

by_begin_end <- purrr::map2(begin_start, end_stop,
                            function(x,y){

                              data_to_get <- data %>% 
                                slice(x:y)
                              by_groups <- list(data = data_to_get %>%
                                                  filter(!type %in% c("begin_group", "end_group")),
                                                information = data_to_get %>%
                                                  filter(type %in% c("begin_group", "end_group"))
                              )
                              # names(by_groups) <- by_groups[["information"]][["name"]]

                              by_groups
                            }) %>% 
  purrr::set_names(nm = purrr::map(., ~ .x[["information"]][["name"]][1]))

test_that("utils_xlsform works", {
  expect_true(inherits(get_groups, "function")) 

ref <- Referential$new(
  path = system.file("SurveyDesigner_Referential.xlsx", package = "surveyDesigner") 
)

result <- get_groups(ref$data$survey)

expect_named(result[[1]], c("data", "information"))
expect_type(result, "list")


expect_true(inherits(get_choices_for_question, "function"))
get_choices <- get_choices_for_question(ref$data$choices, "pop_groups")

expect_type(get_choices, "list")

})

# Run but keep eval=FALSE to avoid infinite loop
# Execute in the console directly
fusen::inflate(
  flat_file = "dev/flat_r6_referential.Rmd", 
  vignette_name = "Class R6 for the referential"
  )

unhcr-americas/surveyDesigner documentation built on Sept. 29, 2023, 9:13 p.m.