DESCRIPTION

@@ -1,6 +1,6 @@
 Package: REDCapCAST
 Title: REDCap Metadata Casting and Castellated Data Handling
-Version: 25.11.1
+Version: 25.3.2
 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,9 +1,3 @@
-# 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)) | identical("logical", class(.x))) {
+        if (identical("factor", class(.x))) {
           as.numeric(.x)
         } else {
           .x

R/utils.r

@@ -99,30 +99,19 @@ 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' '_]", "",
-        gsub(
+        tolower(x)
-          "*_$", "",
-          gsub(
-            "^_*", "",
-            gsub(
-              "[' ']$", "",
-              gsub(
-                "[^a-z0-9' '_]", "",
-                tolower(x)
-              )
-            )
-          )
-        )
       )
     )
   )
+  )
 }
 
 
@@ -147,14 +136,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")
@@ -164,16 +153,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]
 }
 
 
@@ -368,10 +357,8 @@ split_non_repeating_forms <-
 #' @export
 #'
 #' @examples
-#' test <- c(
+#' test <- c("12 months follow-up", "3 steps", "mRS 6 weeks",
-#'   "12 months follow-up", "3 steps", "mRS 6 weeks",
+#' "Counting to 231 now")
-#'   "Counting to 231 now"
-#' )
 #' strsplitx(test, "[0-9]", type = "around")
 strsplitx <- function(x,
                       split,
@@ -530,7 +517,7 @@ is_repeated_longitudinal <- function(data, generics = c(
 }
 
 
-dummy_fun <- function(...) {
+dummy_fun <- function(...){
   list(
     gtsummary::add_difference()
   )
@@ -546,10 +533,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:
+bundleId: 9642648
 url: https://agdamsbo.shinyapps.io/redcapcast/
 version: 1

renv/activate.R

@@ -2,7 +2,7 @@
 local({
 
   # the requested version of renv
-  version <- "1.1.5"
+  version <- "1.0.11"
   attr(version, "sha") <- NULL
 
   # the project directory
@@ -42,7 +42,7 @@ local({
       return(FALSE)
 
     # next, check environment variables
-    # prefer using the configuration one in the future
+    # TODO: 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;;x-r-help:\\1\a?\\1\033]8;;\a`"
+    replacement <- "`\033]8;;ide:help:\\1\a?\\1\033]8;;\a`"
     text <- gsub(pattern, replacement, text, perl = TRUE)
   
     # runnable code
     pattern <- "`(renv::(?:[^`])+)`"
-    replacement <- "`\033]8;;x-r-run:\\1\a\\1\033]8;;\a`"
+    replacement <- "`\033]8;;ide:run:\\1\a\\1\033]8;;\a`"
     text <- gsub(pattern, replacement, text, perl = TRUE)
   
     # return ansified text
@@ -209,6 +209,10 @@ local({
   
   }
   
+  startswith <- function(string, prefix) {
+    substring(string, 1, nchar(prefix)) == prefix
+  }
+  
   bootstrap <- function(version, library) {
   
     friendly <- renv_bootstrap_version_friendly(version)
@@ -559,9 +563,6 @@ 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)
@@ -695,19 +696,11 @@ local({
   
   }
   
-  renv_bootstrap_platform_prefix_default <- function() {
+  renv_bootstrap_platform_prefix <- function() {
   
-    # read version component
+    # construct version prefix
-    version <- Sys.getenv("RENV_PATHS_VERSION", unset = "R-%v")
+    version <- paste(R.version$major, R.version$minor, sep = ".")
-  
+    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)
@@ -716,19 +709,10 @@ local({
       identical(R.version[["nickname"]], "Unsuffered Consequences")
   
     if (devel)
-      version <- paste(version, R.version[["svn rev"]], sep = "-r")
+      prefix <- paste(prefix, 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(version, R.version$platform)
+    components <- c(prefix, R.version$platform)
   
     # include prefix if provided by user
     prefix <- renv_bootstrap_platform_prefix_impl()
@@ -967,14 +951,8 @@ local({
   }
   
   renv_bootstrap_validate_version_dev <- function(version, description) {
-  
     expected <- description[["RemoteSha"]]
-    if (!is.character(expected))
+    is.character(expected) && startswith(expected, version)
-      return(FALSE)
-  
-    pattern <- sprintf("^\\Q%s\\E", version)
-    grepl(pattern, expected, perl = TRUE)
-  
   }
   
   renv_bootstrap_validate_version_release <- function(version, description) {
@@ -1154,10 +1132,10 @@ local({
   
   renv_bootstrap_exec <- function(project, libpath, version) {
     if (!renv_bootstrap_load(project, libpath, version))
-      renv_bootstrap_run(project, libpath, version)
+      renv_bootstrap_run(version, libpath)
   }
   
-  renv_bootstrap_run <- function(project, libpath, version) {
+  renv_bootstrap_run <- function(version, libpath) {
   
     # perform bootstrap
     bootstrap(version, libpath)
@@ -1168,7 +1146,7 @@ local({
   
     # try again to load
     if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) {
-      return(renv::load(project = project))
+      return(renv::load(project = getwd()))
     }
   
     # failed to download or load renv; warn the user
@@ -1214,105 +1192,98 @@ 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) {
   
-    # read json text
+    # find strings in the JSON
     text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n")
+    pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]'
+    locs <- gregexpr(pattern, text, perl = TRUE)[[1]]
   
-    # convert into something the R parser will understand
+    # if any are found, replace them with placeholders
-    patterns <- renv_json_read_patterns()
+    replaced <- text
-    transformed <- text
+    strings <- character()
-    for (pattern in patterns)
+    replacements <- character()
-      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
-    rfile <- tempfile("renv-json-", fileext = ".R")
+    json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]]
-    on.exit(unlink(rfile), add = TRUE)
-    writeLines(transformed, con = rfile)
-    json <- parse(rfile, keep.source = FALSE, srcfile = NULL)[[1L]]
   
-    # evaluate in safe environment
+    # construct map between source strings, replaced strings
-    result <- eval(json, envir = renv_json_read_envir())
+    map <- as.character(parse(text = strings))
+    names(map) <- as.character(parse(text = replacements))
   
-    # fix up strings if necessary -- do so only with reversible patterns
+    # convert to list
-    patterns <- Filter(function(pattern) pattern[[3L]], patterns)
+    map <- as.list(map)
-    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)