update the scan_date() function - only scan through character columns

R/clean_data_helpers.R

@@ -1,222 +1,147 @@
-
-#' Calculate the percentage of missing and other data type values in a vector
-#' containing different data types such as numeric, Date, character,
-#' logical, date-time, factor.
-#'
-#' @param x A vector of ones or a combination of various data types.
-#' @param type A character with the the vector type.
-#'
-#' @returns A vector of 5 elements representing the percentage of missing,
-#' numeric, date, character, and logical values found in the input vector.
-#'
-#' @keywords internal
-#'
-scan_columns <- function(x, type) {
- res <- switch(type,
- double = scan_in_double(x),
- integer = scan_in_integer(x),
- logical = scan_in_logical(x),
- character = scan_in_character(x))
- return(res)
-}
-
-#' Scan a data frame to determine the percentage of `missing`, `numeric`,
-#' `Date`, `character`, `logical`, `date-time`, and `factor` values in every
-#' column.
+#' Scan through all character columns of a data frame to determine the
+#' proportion of `missing`, `numeric`, `Date`, `character`, `logical`, values.
 #'
 #' @param data A data frame or linelist
 #'
-#' @returns A data frame or linelist with the same number of rows as the number
-#' of columns of the input data, and 8 column representing the field names,
-#' the percentage of missing, numeric, date, character, logical, date-time,
-#' and factor values in each column.
+#' @returns A data frame with the same number of rows as the number of character
+#' columns of the input data, and six (06) columns representing the field
+#' names, the percentage of missing, numeric, date, character, and logical,
+#' values in each column.
 #'
 #' @export
 #'
 #' @examples
+#' # scan through a data frame of characters
 #' scan_result <- scan_data(
 #' data = readRDS(system.file("extdata", "messy_data.RDS",
 #' package = "cleanepi"))
 #' )
 #'
-#' @details
-#' For columns of type character, the detected numeric values could actually be
-#' of type Date or date-time. This is because R coerces some Date values into
-#' numeric when the date is imported from an MS Excel file.
+#' # scan through a data frame with two character columns
+#' scan_result <- scan_data(
+#' data = readRDS(system.file("extdata", "test_linelist.RDS",
+#' package = "cleanepi"))
+#' )
+#'
+#' # scan through a data frame with no character columns
+#' data(iris)
+#' iris[["fct"]] <- as.factor(sample(c("gray", "orange"), nrow(iris),
+#' replace = TRUE))
+#' iris[["lgl"]] <- sample(c(TRUE, FALSE), nrow(iris), replace = TRUE)
+#' iris[["date"]] <- as.Date(seq.Date(from = as.Date("2024-01-01"),
+#' to = as.Date("2024-08-30"),
+#' length.out = nrow(iris)))
+#' iris[["posit_ct"]] <- as.POSIXct(iris[["date"]])
+#' scan_result <- scan_data(data = iris)
 #'
 scan_data <- function(data) {
- types <- vapply(data, typeof, character(1L))
+ # scan through all columns of the data and the identify character columns
+ types <- vapply(data, typeof, character(1L))
+ target_columns <- types[types == "character"]
+
+ # send an message if there is no character column found within the input data
+ if (length(target_columns) == 0L) {
+ message("No character column found in the provided data.")
+ return(invisible(NA))
+ }
+
+ # scan through the character columns
+ data <- data[, names(target_columns)]
  scan_result <- vapply(seq_len(ncol(data)), function(col_index) {
- scan_columns(data[[col_index]], types[[col_index]])
- }, numeric(7L))
+ scan_in_character(data[[col_index]])
+ }, numeric(5L))
  scan_result <- as.data.frame(t(scan_result))
- names(scan_result) <- c("missing", "numeric", "date", "character",
- "logical", "date-time", "factor")
+ names(scan_result) <- c("missing", "numeric", "date", "character", "logical")
  scan_result <- cbind(Field_names = names(data), scan_result)
  return(scan_result)
 }
 
-#' Scan through a double column
-#'
-#' @param x The input vector
-#'
-#' @return A numeric vector with the proportion of the different types of data
-#' that were detected within the input vector.
-#' @keywords internal
-#'
-scan_in_double <- function(x) {
- are_factor <- are_date <- are_date_time <- are_character <- are_numeric <-
- are_logical <- are_na <- 0.0
- # save the variable length
- n_rows <- length(x)
-
- # get the proportion of NA
- are_na <- round((sum(is.na(x)) / n_rows), 6L)
- x <- x[!is.na(x)]
-
- # doubles are either numeric (attributes = NULL), or Date (has a 'class'
- # attributes = Date), or date-time (has a 'class' attributes = POSIXt)
- if ("class" %in% names(attributes(x))) {
- if ("Date" %in% attributes(x)[["class"]]) {
- are_date <- round((length(x) / n_rows), 6L)
- } else if ("POSIXt" %in% attributes(x)[["class"]]) {
- are_date_time <- round((length(x) / n_rows), 6L)
- }
- } else {
- are_numeric <- round((length(x) / n_rows), 6L)
- }
- return(
- c(are_na, are_numeric, are_date, are_character, are_logical, are_date_time,
- are_factor)
- )
-}
-
-#' Scan through an integer column
-#'
-#' @param x The input vector
-#'
-#' @return A numeric vector with the proportion of the different types of data
-#' that were detected within the input vector.
-#' @keywords internal
-#'
-scan_in_integer <- function(x) {
- are_factor <- are_date <- are_date_time <- are_character <- are_numeric <-
- are_logical <- are_na <- 0.0
- # save the variable length
- n_rows <- length(x)
-
- # get the proportion of NA
- are_na <- round((sum(is.na(x)) / n_rows), 6L)
- x <- x[!is.na(x)]
-
- # integers are either numeric (attributes = NULL), or factors (has a 'class'
- # and 'levels' attributes)
- if (is.null(attributes(x))) {
- are_numeric <- round((length(x) / n_rows), 6L)
- } else if (identical(names(attributes(x)), c("levels", "class"))) {
- are_factor <- round((length(x) / n_rows), 6L)
- }
-
- return(
- c(are_na, are_numeric, are_date, are_character, are_logical, are_date_time,
- are_factor)
- )
-}
-
-#' Scan through a logical column
-#'
-#' @param x The input vector
-#'
-#' @return A numeric vector with the proportion of the different types of data
-#' that were detected within the input vector.
-#' @keywords internal
-#'
-scan_in_logical <- function(x) {
- are_factor <- are_date <- are_date_time <- are_character <- are_numeric <-
- are_logical <- are_na <- 0.0
-
- # logical are simply logical. We will only determine the %NA and %logical
- # save the variable length
- n_rows <- length(x)
-
- # get the proportion of NA
- are_na <- round((sum(is.na(x)) / n_rows), 6L)
- x <- x[!is.na(x)]
-
- # get the proportion of logical
- are_logical <- round((length(x) / n_rows), 6L)
- return(
- c(are_na, are_numeric, are_date, are_character, are_logical, are_date_time,
- are_factor)
- )
-}
-
 #' Scan through a character column
 #'
-#' @param x The input vector
+#' @param x The input character vector
 #'
 #' @return A numeric vector with the proportion of the different types of data
 #' that were detected within the input vector.
 #' @keywords internal
 #'
 scan_in_character <- function(x) {
  # There might be, within a character column, values of type:
- # character, numeric, date, date-time, NA, and logical
+ # character, numeric, date (date or date-time), NA, and logical
  # In this function, we check the presence of these different types within a
  # character column.
- # Note that numeric values can actually be of 'Date' or 'date-time' type.
- # Given that any numeric can be converted into Date, we will not check for
- # Date or date-time values within the numeric.
-
- are_factor <- are_date <- are_date_time <- are_character <- are_numeric <-
- are_logical <- are_na <- 0.0
 
  # save the variable length
- n_rows <- length(x)
+ initial_length <- length(x)
 
- # get the proportion of NA
- are_na <- round((sum(is.na(x)) / n_rows), 6L)
+ # get the count of missing data (NA)
+ na_count <- sum(is.na(x))
  x <- x[!is.na(x)]
 
- # get double values and evaluate the proportion numeric values
- doubles <- x[!is.na(suppressWarnings(as.double(x)))]
- if (length(doubles) > 0L) {
-  are_numeric <- round((length(doubles) / n_rows), 6L)
- }
-
- # get character values and check for the presence of Date and date-time
- characters <- x[is.na(suppressWarnings(as.double(x)))]
- if (length(characters) > 0L &&
-  !is.null(lubridate::guess_formats(characters,
-  c("ymd", "ydm", "dmy", "mdy", "myd",
-  "dym", "Ymd", "Ydm", "dmY", "mdY",
-  "mYd", "dYm")))) {
- # get the proportion of date values
-  tmp <- suppressWarnings(
-  as.Date(
-  lubridate::parse_date_time(
-  characters,
-  orders = c("ymd", "ydm", "dmy", "mdy", "myd", "dym", "Ymd", "Ydm",
-  "dmY", "mdY", "mYd", "dYm")
- )
+ # We will check if there is any Date values within the variable by parsing the
+ # values, looking for the ones that fit any of the predefined format.
+ # When there is one or more Date values, we will convert the variable into
+ # numeric and determine if any of them is a Date (a numeric, which after
+ # conversion to Date, fall within the interval
+ # [50 years back from today's date, today's date]). That way the Date count is
+ # the count of date identified from the parsing + the count of Dates within
+ # the numeric values.
+ # When there is no Date values identified from the parsing, the variable
+ # is converted into numeric. The numeric count is the sum of numeric values.
+ # The logical count is the number of TRUE and FALSE written in both lower
+ # and upper case within the variable
+ # The remaining values will be of type character.
+
+ # parsing the vector, looking for date values
+ tmp <- suppressWarnings(
+ as.Date(
+ lubridate::parse_date_time(
+ x,
+ orders = c("ymd", "ydm", "dmy", "mdy", "myd", "dym", "Ymd", "Ydm",
+  "dmY", "mdY", "mYd", "dYm")
  )
  )
- are_date <- round((sum(!is.na(tmp)) / n_rows), 6L)
- x <- x[is.na(tmp)]
- characters <- characters[is.na(tmp)]
+ )
+
+ # getting the date and numeric count as describe above
+ date_count <- numeric_count <- 0L
+ if (sum(!is.na(tmp)) > 0L) {
+ # Setting the first date to 50 years before the current date
+ target_interval <- sort(
+ seq.Date(Sys.Date(), length.out = 2L, by = "-50 years")
+ )
+
+ # get the date count
+ date_count <- date_count + sum(!is.na(tmp))
+
+ # convert to numeric and check for the presence of Date among the numeric
+ tmp2 <- x[is.na(tmp)]
+ tmp3 <- suppressWarnings(as.numeric(tmp2))
+ if (sum(!is.na(tmp3)) > 0L) {
+ y <- lubridate::as_date(
+ tmp3[!is.na(tmp3)],
+ origin = target_interval[[1L]]
+ )
+ # second count of date values coming from date within numeric
+ date_count <- date_count + sum(!is.na(y))
+ numeric_count <- sum(is.na(y))
+ }
+ } else {
+ tmp <- suppressWarnings(as.numeric(x))
+ numeric_count <- sum(!is.na(tmp))
  }
 
- # get the proportion of logical values
- logicals <- toupper(characters) == "TRUE" | toupper(characters) == "FALSE"
- are_logical <- round((sum(logicals) / n_rows), 6L)
+ # get logical count
+ logicals <- toupper(x) == "TRUE" | toupper(x) == "FALSE"
+ logical_count <- sum(logicals)
 
- # get the proportion of character values
- are_character <- round((1.0 - (are_na + are_numeric +
-  are_date + are_logical)), 6L)
+ # get the character count
+ character_count <- initial_length -
+ (na_count + logical_count + numeric_count + date_count)
 
- # return the output
- return(
- c(are_na, are_numeric, are_date, are_character, are_logical, are_date_time,
- are_factor)
- )
+ # transform into proportions
+ props <- round(
+ c(na_count, numeric_count, date_count, character_count, logical_count) /
+ initial_length, 4L)
+
+ return(props)
 }

inst/rmarkdown/templates/printing-rmd/skeleton/skeleton.Rmd

@@ -59,7 +59,7 @@ p.compact {
 ```{r cleanepi-source-data, eval=TRUE, echo=FALSE}
 # EXTRACT THE REPORT SECTIONS
 scanning_result <- params[["scanning_result"]]
-is_data_scanned <- !is.null(scanning_result)
+is_data_scanned <- !is.na(scanning_result)
 standardized_column_names <- params[["colnames"]]
 are_column_standardised <- !is.null(standardized_column_names)
 out_of_range_dates <- params[["out_of_range_dates"]]