diff --git a/R/calculationEnvironment.R b/R/calculationEnvironment.R new file mode 100644 index 00000000..647c54ca --- /dev/null +++ b/R/calculationEnvironment.R @@ -0,0 +1,122 @@ +#' @keywords internal + +.redcapCalculationEnvironment <- function() { + mather <- function(f, na.rm = TRUE, ...) { + args <- list(...) + do.call(f, c(args, na.rm = na.rm)) + } + + numeric_functions <- list( + round = function(number, digits = 0) round(number, digits), + roundup = function(number, digits = 0) { + base <- 10^digits + ceiling(number * base) / base + }, + rounddown = function(number, digits = 0) { + base <- 10^digits + floor(number * base) / base + }, + sqrt = function(x) sqrt(x), + abs = function(x) abs(x), + exponential = function(...) mather(exp, na.rm = FALSE, ...), + min = function(...) mather(min, ...), + max = function(...) mather(max, ...), + mean = function(...) mather(mean, ...), + median = function(...) mather(median, ...), + mod = function(dividend, divisor) dividend %% divisor, + sum = function(...) mather(sum, ...), + stdev = function(...) mather(sd, ...), + log = function(number, base) log(number, base), + isnumber = function(x) !is.na(suppressWarnings(as.numeric(x))), + isinteger = function(x) grepl('^[0-9]$', x) + ) + + dater <- function(date) { + if(inherits(date, 'character')) { + date <- gsub('"|\'', '', date) + useDT <- FALSE + if(any(date %in% 'now')) { + now <- format(Sys.time(), '%Y-%m-%d %H:%M:%S') + date[date == 'now'] <- now + useDT <- TRUE + } + if(any(date %in% 'today')) { + today <- format(Sys.Date(), '%Y-%m-%d') + date[date == 'today'] <- today + } + if(useDT) { + date <- as.POSIXct(date) + } else { + date <- as.Date(date) + } + } + date + } + + date_functions <- list( + year = function(date) format(dater(date), '%Y'), + month = function(date) format(dater(date), '%m'), + day = function(date) format(dater(date), '%d') + ) + + searcher <- function(haystack, needle) { + grepl(needle, haystack, ignore.case = TRUE) + } + + text_functions <- list( + contains = function(h, n) searcher(h, n), + not_contain = function(h, n) !searcher(h, n), + starts_with = function(h, n) searcher(h, sprintf('^%s', n)), + ends_with = function(h, n) searcher(h, sprintf('%s$', n)), + left = function(x, n = 1) substr(x, 1, n), + right = function(x, n = 1) substr(x, nchar(x) - n + 1, nchar(x)), + length = function(x) nchar(x), + find = function(needle, haystack) { + m <- c(regexpr(needle, haystack, ignore.case = TRUE)[[1]])[1] + m[m == -1] <- 0 + m + }, + replace_text = function(h, s, r) gsub(s, r, h, fixed = TRUE), + mid = function(x, start = 1, n = 1) substr(x, start, start + n - 1), + concat = function(...) do.call(paste0, list(...)), + concat_ws = function(sep, ...) do.call(paste0, list(list(...), collapse = sep)), + upper = function(x) toupper(x), + lower = function(x) tolower(x), + trim = function(x) trimws(x) + ) + + misc_functions <- list( + doif = function(test, yes, no) { + ifelse(test, yes, no) + }, + datediff = function(date1, date2, units = 'd', signed = FALSE) { + date1 <- dater(date1) + date2 <- dater(date2) + # "Date" objects will take on 'UTC' timezone by default + # force character conversion + if(inherits(date1, 'Date')) { + date1 <- as.POSIXct(format(date1, '%Y-%m-%d')) + } + if(inherits(date2, 'Date')) { + date2 <- as.POSIXct(format(date2, '%Y-%m-%d')) + } + dt <- as.numeric(difftime(date2, date1, units = 'secs')) + if(!signed) dt <- abs(dt) + den <- switch(units, + s = 1, + m = 60, + h = 3600, + d = 86400, + M = 2630016, # 86400*30.44 + y = 31556952 # 86400*365.2425 + ) + dt / den + }, + isblankormissing = function(value, missing_value_code = NULL) { + is.na(value) | is.null(value) | value %in% c('', missing_value_code) + } + ) + + redcap_functions <- c(numeric_functions, date_functions, text_functions, misc_functions) + list2env(redcap_functions) +} diff --git a/R/fieldCastingFunctions.R b/R/fieldCastingFunctions.R index da7848f4..aa0b3f62 100644 --- a/R/fieldCastingFunctions.R +++ b/R/fieldCastingFunctions.R @@ -547,14 +547,31 @@ mChoiceCast <- function(data, ################################################################### # Derive field information #### MetaData <- rcon$metadata() - - field_names <- names(Raw) - + + field_names <- names(Raw) + field_bases <- sub(REGEX_CHECKBOX_FIELD_NAME, #defined in constants.R "\\1", field_names, perl = TRUE) - field_text_types <- MetaData$text_validation_type_or_show_slider_number[match(field_bases, MetaData$field_name)] field_map <- match(field_bases, MetaData$field_name) - + field_text_types <- MetaData$text_validation_type_or_show_slider_number[field_map] + + ################################################################### + # Recalculate Values from "calc" fields #### + calc_data <- NULL + calc_fields <- MetaData[MetaData[,'field_type'] == 'calc',] + nr <- nrow(calc_fields) + if(nr > 0L) { + calc_data <- Raw[,'record_id', drop = FALSE] + raw_name <- field_names[match(calc_fields[,'field_name'], field_bases)] + calc_data[,paste0(raw_name, '_recalc')] <- NA + for(i in seq_len(nr)) { + expr_i <- calc_fields[i,'select_choices_or_calculations'] + calc_i <- .redcapCalculation(expr_i, Raw) + calc_data[,i+1] <- calc_i + } + calc_data <- calc_data[, -1, drop = FALSE] + } + field_types <- .castRecords_getFieldTypes(rcon = rcon, field_map = field_map, field_bases = field_bases, @@ -628,6 +645,12 @@ mChoiceCast <- function(data, field_names = field_names, field_types = field_types) + ################################################################### + # Recalculated Values #### + if(!is.null(calc_data)) { + Records <- cbind(Records, calc_data) + } + ################################################################### # Return Results #### Records diff --git a/R/redcapCalculations.R b/R/redcapCalculations.R new file mode 100644 index 00000000..85af3583 --- /dev/null +++ b/R/redcapCalculations.R @@ -0,0 +1,50 @@ +#' @keywords internal +.calculationToLanguage <- function(x) { + if(grepl('(^|\\b)if\\(', x, ignore.case = TRUE)) { + x <- gsub('(^|\\b)if\\(', 'doif(', x, ignore.case = TRUE) + x <- gsub('(?', '!=', x) + } + y <- gregexpr('\\[[^[]+\\]', x)[[1]] + if(length(y) > 1 || y[[1]] != -1) { + ytxt <- mapply(substr, x, y + 1, y + attr(y, 'match.length') - 2, USE.NAMES = FALSE) + yseq <- mapply(seq, y, length.out = attr(y, 'match.length'), USE.NAMES = FALSE, SIMPLIFY = FALSE) + xseq <- setdiff(seq(nchar(x)), unlist(yseq)) + xbrk <- cumsum(c(FALSE, diff(xseq) > 1)) + xgrp <- split(strsplit(x, '')[[1]][xseq], xbrk) + xstr <- vapply(xgrp, paste, character(1), collapse = '', USE.NAMES = FALSE) + nn <- length(xstr) * 2 - 1 + x1 <- character(nn) + x1[seq(1, nn, by = 2)] <- xstr + x1[seq(2, nn, by = 2)] <- ytxt + x2 <- paste(x1, collapse = '') + str2lang(x2) + } else { + str2lang(x) + } +} + +#' @keywords internal +.calculationEval <- function(x, env, call_string) { + tryCatch(eval(x, envir = env), error = function(e) { + stop(sprintf('Error in %s: %s', call_string, e[[1]])) + }) +} + +#' @keywords internal +.redcapCalculation <- function(expr, dat = NULL) { + x <- .calculationToLanguage(expr) + xstr <- as.character(as.expression(x)) + e <- new.env(parent = .redcapCalculationEnvironment()) + if(!is.null(dat)) { + nr <- nrow(dat) + res <- lapply(seq_len(nr), function(i) { + list2env(dat[i,], envir = e) + .calculationEval(x, e, xstr) + }) + res <- unlist(res) + } else { + res <- .calculationEval(x, e, xstr) + } + res +}