new version

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: REDCapCAST
 Title: REDCap Metadata Casting and Castellated Data Handling
-Version: 25.3.2
+Version: 25.11.1
 Authors@R: c(
     person("Andreas Gammelgaard", "Damsbo", email = "agdamsbo@clin.au.dk", 
     role = c("aut", "cre"),comment = c(ORCID = "0000-0002-7559-1154")), 

NEWS.md

@@ -1,3 +1,9 @@
+# REDCapCAST 25.11.1
+
+* FIX: logiccals exported as numeric for data upload
+
+* FIX: improved name cleaning
+
 # REDCapCAST 25.3.2
 
 * BUG: The `redcap_wider()` function would attempt to pivot empty selection of columns from list, and failing, causing all functions relying on this to fail. Fixed by filtering out data.frames in list with no additional columns than the "generics". 

R/ds2dd_detailed.R

@@ -446,7 +446,7 @@ ds2dd_detailed <- function(data,
       hms2character() |>
       stats::setNames(dd$field_name) |>
       lapply(\(.x){
-        if (identical("factor", class(.x))) {
+        if (identical("factor", class(.x)) | identical("logical", class(.x))) {
           as.numeric(.x)
         } else {
           .x

R/utils.r

@@ -99,19 +99,30 @@ focused_metadata <- function(metadata, vars_in_data) {
 #'
 #' @examples
 #' "Research!, ne:ws? and c;l-.ls" |> clean_redcap_name()
+#' "8_new_TEST_" |> clean_redcap_name()
 clean_redcap_name <- function(x) {
-  gsub("[,.;:?!@]","",
   gsub(
-    " ", "_",
+    "[,.;:?!@]", "",
     gsub(
-      "[' ']$", "",
+      " ", "_",
       gsub(
-        "[^a-z0-9' '_]", "",
+        "__", "_",
-        tolower(x)
+        gsub(
+          "*_$", "",
+          gsub(
+            "^_*", "",
+            gsub(
+              "[' ']$", "",
+              gsub(
+                "[^a-z0-9' '_]", "",
+                tolower(x)
+              )
+            )
+          )
+        )
       )
     )
   )
-  )
 }
 
 
@@ -136,14 +147,14 @@ sanitize_split <- function(l,
                              "redcap_repeat_instrument",
                              "redcap_repeat_instance"
                            ),
-                           drop.complete=TRUE,
+                           drop.complete = TRUE,
-                           drop.empty=TRUE) {
+                           drop.empty = TRUE) {
   generic.names <- c(
     get_id_name(l),
     generic.names
   )
 
-  if (drop.complete){
+  if (drop.complete) {
     generic.names <- c(
       generic.names,
       paste0(names(l), "_complete")
@@ -153,16 +164,16 @@ sanitize_split <- function(l,
   out <- lapply(l, function(i) {
     if (ncol(i) > 2) {
       s <- i[!colnames(i) %in% generic.names]
-      if (drop.empty){
+      if (drop.empty) {
-      i[!apply(is.na(s), MARGIN = 1, FUN = all), ]
+        i[!apply(is.na(s), MARGIN = 1, FUN = all), ]
-        }
+      }
     } else {
       i
     }
   })
 
   # On removing empty variables, a list may end up empty
-  out[sapply(out,nrow)>0]
+  out[sapply(out, nrow) > 0]
 }
 
 
@@ -357,8 +368,10 @@ split_non_repeating_forms <-
 #' @export
 #'
 #' @examples
-#' test <- c("12 months follow-up", "3 steps", "mRS 6 weeks",
+#' test <- c(
-#' "Counting to 231 now")
+#'   "12 months follow-up", "3 steps", "mRS 6 weeks",
+#'   "Counting to 231 now"
+#' )
 #' strsplitx(test, "[0-9]", type = "around")
 strsplitx <- function(x,
                       split,
@@ -517,7 +530,7 @@ is_repeated_longitudinal <- function(data, generics = c(
 }
 
 
-dummy_fun <- function(...){
+dummy_fun <- function(...) {
   list(
     gtsummary::add_difference()
   )
@@ -533,10 +546,10 @@ dummy_fun <- function(...){
 #' @export
 #'
 #' @examples
-#' "length" |> cut_string_length(l=3)
+#' "length" |> cut_string_length(l = 3)
-cut_string_length <- function(data,l=100){
+cut_string_length <- function(data, l = 100) {
-  if (nchar(data)>=l){
+  if (nchar(data) >= l) {
-    substr(data,1,l)
+    substr(data, 1, l)
   } else {
     data
   }

inst/shiny-examples/casting/rsconnect/shinyapps.io/agdamsbo/redcapcast.dcf

@@ -5,6 +5,6 @@ account: agdamsbo
 server: shinyapps.io
 hostUrl: https://api.shinyapps.io/v1
 appId: 11351429
-bundleId: 9642648
+bundleId:
 url: https://agdamsbo.shinyapps.io/redcapcast/
 version: 1

renv/activate.R

@@ -2,7 +2,7 @@
 local({
 
   # the requested version of renv
-  version <- "1.0.11"
+  version <- "1.1.5"
   attr(version, "sha") <- NULL
 
   # the project directory
@@ -42,7 +42,7 @@ local({
       return(FALSE)
 
     # next, check environment variables
-    # TODO: prefer using the configuration one in the future
+    # prefer using the configuration one in the future
     envvars <- c(
       "RENV_CONFIG_AUTOLOADER_ENABLED",
       "RENV_AUTOLOADER_ENABLED",
@@ -135,12 +135,12 @@ local({
   
     # R help links
     pattern <- "`\\?(renv::(?:[^`])+)`"
-    replacement <- "`\033]8;;ide:help:\\1\a?\\1\033]8;;\a`"
+    replacement <- "`\033]8;;x-r-help:\\1\a?\\1\033]8;;\a`"
     text <- gsub(pattern, replacement, text, perl = TRUE)
   
     # runnable code
     pattern <- "`(renv::(?:[^`])+)`"
-    replacement <- "`\033]8;;ide:run:\\1\a\\1\033]8;;\a`"
+    replacement <- "`\033]8;;x-r-run:\\1\a\\1\033]8;;\a`"
     text <- gsub(pattern, replacement, text, perl = TRUE)
   
     # return ansified text
@@ -209,10 +209,6 @@ local({
   
   }
   
-  startswith <- function(string, prefix) {
-    substring(string, 1, nchar(prefix)) == prefix
-  }
-  
   bootstrap <- function(version, library) {
   
     friendly <- renv_bootstrap_version_friendly(version)
@@ -563,6 +559,9 @@ local({
   
     # prepare download options
     token <- renv_bootstrap_github_token()
+    if (is.null(token))
+      token <- ""
+  
     if (nzchar(Sys.which("curl")) && nzchar(token)) {
       fmt <- "--location --fail --header \"Authorization: token %s\""
       extra <- sprintf(fmt, token)
@@ -696,11 +695,19 @@ local({
   
   }
   
-  renv_bootstrap_platform_prefix <- function() {
+  renv_bootstrap_platform_prefix_default <- function() {
   
-    # construct version prefix
+    # read version component
-    version <- paste(R.version$major, R.version$minor, sep = ".")
+    version <- Sys.getenv("RENV_PATHS_VERSION", unset = "R-%v")
-    prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-")
+  
+    # expand placeholders
+    placeholders <- list(
+      list("%v", format(getRversion()[1, 1:2])),
+      list("%V", format(getRversion()[1, 1:3]))
+    )
+  
+    for (placeholder in placeholders)
+      version <- gsub(placeholder[[1L]], placeholder[[2L]], version, fixed = TRUE)
   
     # include SVN revision for development versions of R
     # (to avoid sharing platform-specific artefacts with released versions of R)
@@ -709,10 +716,19 @@ local({
       identical(R.version[["nickname"]], "Unsuffered Consequences")
   
     if (devel)
-      prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r")
+      version <- paste(version, R.version[["svn rev"]], sep = "-r")
+  
+    version
+  
+  }
+  
+  renv_bootstrap_platform_prefix <- function() {
+  
+    # construct version prefix
+    version <- renv_bootstrap_platform_prefix_default()
   
     # build list of path components
-    components <- c(prefix, R.version$platform)
+    components <- c(version, R.version$platform)
   
     # include prefix if provided by user
     prefix <- renv_bootstrap_platform_prefix_impl()
@@ -951,8 +967,14 @@ local({
   }
   
   renv_bootstrap_validate_version_dev <- function(version, description) {
+  
     expected <- description[["RemoteSha"]]
-    is.character(expected) && startswith(expected, version)
+    if (!is.character(expected))
+      return(FALSE)
+  
+    pattern <- sprintf("^\\Q%s\\E", version)
+    grepl(pattern, expected, perl = TRUE)
+  
   }
   
   renv_bootstrap_validate_version_release <- function(version, description) {
@@ -1132,10 +1154,10 @@ local({
   
   renv_bootstrap_exec <- function(project, libpath, version) {
     if (!renv_bootstrap_load(project, libpath, version))
-      renv_bootstrap_run(version, libpath)
+      renv_bootstrap_run(project, libpath, version)
   }
   
-  renv_bootstrap_run <- function(version, libpath) {
+  renv_bootstrap_run <- function(project, libpath, version) {
   
     # perform bootstrap
     bootstrap(version, libpath)
@@ -1146,7 +1168,7 @@ local({
   
     # try again to load
     if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) {
-      return(renv::load(project = getwd()))
+      return(renv::load(project = project))
     }
   
     # failed to download or load renv; warn the user
@@ -1192,98 +1214,105 @@ local({
     jsonlite::fromJSON(txt = text, simplifyVector = FALSE)
   }
   
+  renv_json_read_patterns <- function() {
+  
+    list(
+  
+      # objects
+      list("{", "\t\n\tobject(\t\n\t", TRUE),
+      list("}", "\t\n\t)\t\n\t",       TRUE),
+  
+      # arrays
+      list("[", "\t\n\tarray(\t\n\t", TRUE),
+      list("]", "\n\t\n)\n\t\n",      TRUE),
+  
+      # maps
+      list(":", "\t\n\t=\t\n\t", TRUE),
+  
+      # newlines
+      list("\\u000a", "\n", FALSE)
+  
+    )
+  
+  }
+  
+  renv_json_read_envir <- function() {
+  
+    envir <- new.env(parent = emptyenv())
+  
+    envir[["+"]] <- `+`
+    envir[["-"]] <- `-`
+  
+    envir[["object"]] <- function(...) {
+      result <- list(...)
+      names(result) <- as.character(names(result))
+      result
+    }
+  
+    envir[["array"]] <- list
+  
+    envir[["true"]]  <- TRUE
+    envir[["false"]] <- FALSE
+    envir[["null"]]  <- NULL
+  
+    envir
+  
+  }
+  
+  renv_json_read_remap <- function(object, patterns) {
+  
+    # repair names if necessary
+    if (!is.null(names(object))) {
+  
+      nms <- names(object)
+      for (pattern in patterns)
+        nms <- gsub(pattern[[2L]], pattern[[1L]], nms, fixed = TRUE)
+      names(object) <- nms
+  
+    }
+  
+    # repair strings if necessary
+    if (is.character(object)) {
+      for (pattern in patterns)
+        object <- gsub(pattern[[2L]], pattern[[1L]], object, fixed = TRUE)
+    }
+  
+    # recurse for other objects
+    if (is.recursive(object))
+      for (i in seq_along(object))
+        object[i] <- list(renv_json_read_remap(object[[i]], patterns))
+  
+    # return remapped object
+    object
+  
+  }
+  
   renv_json_read_default <- function(file = NULL, text = NULL) {
   
-    # find strings in the JSON
+    # read json text
     text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n")
-    pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]'
-    locs <- gregexpr(pattern, text, perl = TRUE)[[1]]
   
-    # if any are found, replace them with placeholders
+    # convert into something the R parser will understand
-    replaced <- text
+    patterns <- renv_json_read_patterns()
-    strings <- character()
+    transformed <- text
-    replacements <- character()
+    for (pattern in patterns)
-  
+      transformed <- gsub(pattern[[1L]], pattern[[2L]], transformed, fixed = TRUE)
-    if (!identical(c(locs), -1L)) {
-  
-      # get the string values
-      starts <- locs
-      ends <- locs + attr(locs, "match.length") - 1L
-      strings <- substring(text, starts, ends)
-  
-      # only keep those requiring escaping
-      strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE)
-  
-      # compute replacements
-      replacements <- sprintf('"\032%i\032"', seq_along(strings))
-  
-      # replace the strings
-      mapply(function(string, replacement) {
-        replaced <<- sub(string, replacement, replaced, fixed = TRUE)
-      }, strings, replacements)
-  
-    }
-  
-    # transform the JSON into something the R parser understands
-    transformed <- replaced
-    transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE)
-    transformed <- gsub("[[{]", "list(", transformed, perl = TRUE)
-    transformed <- gsub("[]}]", ")", transformed, perl = TRUE)
-    transformed <- gsub(":", "=", transformed, fixed = TRUE)
-    text <- paste(transformed, collapse = "\n")
   
     # parse it
-    json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]]
+    rfile <- tempfile("renv-json-", fileext = ".R")
+    on.exit(unlink(rfile), add = TRUE)
+    writeLines(transformed, con = rfile)
+    json <- parse(rfile, keep.source = FALSE, srcfile = NULL)[[1L]]
   
-    # construct map between source strings, replaced strings
+    # evaluate in safe environment
-    map <- as.character(parse(text = strings))
+    result <- eval(json, envir = renv_json_read_envir())
-    names(map) <- as.character(parse(text = replacements))
   
-    # convert to list
+    # fix up strings if necessary -- do so only with reversible patterns
-    map <- as.list(map)
+    patterns <- Filter(function(pattern) pattern[[3L]], patterns)
-  
+    renv_json_read_remap(result, patterns)
-    # remap strings in object
-    remapped <- renv_json_read_remap(json, map)
-  
-    # evaluate
-    eval(remapped, envir = baseenv())
   
   }
   
-  renv_json_read_remap <- function(json, map) {
-  
-    # fix names
-    if (!is.null(names(json))) {
-      lhs <- match(names(json), names(map), nomatch = 0L)
-      rhs <- match(names(map), names(json), nomatch = 0L)
-      names(json)[rhs] <- map[lhs]
-    }
-  
-    # fix values
-    if (is.character(json))
-      return(map[[json]] %||% json)
-  
-    # handle true, false, null
-    if (is.name(json)) {
-      text <- as.character(json)
-      if (text == "true")
-        return(TRUE)
-      else if (text == "false")
-        return(FALSE)
-      else if (text == "null")
-        return(NULL)
-    }
-  
-    # recurse
-    if (is.recursive(json)) {
-      for (i in seq_along(json)) {
-        json[i] <- list(renv_json_read_remap(json[[i]], map))
-      }
-    }
-  
-    json
-  
-  }
 
   # load the renv profile, if any
   renv_bootstrap_profile_load(project)