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,18 +99,10 @@ 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(
-        "__", "_",
-        gsub(
-          "*_$", "",
-          gsub(
-            "^_*", "",
     gsub(
       "[' ']$", "",
       gsub(
@@ -120,9 +112,6 @@ clean_redcap_name <- function(x) {
     )
   )
   )
-      )
-    )
-  )
 }
 
 
@@ -147,14 +136,14 @@ sanitize_split <- function(l,
                              "redcap_repeat_instrument",
                              "redcap_repeat_instance"
                            ),
-                           drop.complete = TRUE,
-                           drop.empty = TRUE) {
+                           drop.complete=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,7 +153,7 @@ 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), ]
         }
     } else {
@@ -173,7 +162,7 @@ sanitize_split <- function(l,
   })
 
   # 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(
-#'   "12 months follow-up", "3 steps", "mRS 6 weeks",
-#'   "Counting to 231 now"
-#' )
+#' test <- c("12 months follow-up", "3 steps", "mRS 6 weeks",
+#' "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)
-cut_string_length <- function(data, l = 100) {
-  if (nchar(data) >= l) {
-    substr(data, 1, l)
+#' "length" |> cut_string_length(l=3)
+cut_string_length <- function(data,l=100){
+  if (nchar(data)>=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
-    version <- Sys.getenv("RENV_PATHS_VERSION", unset = "R-%v")
-  
-    # 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)
+    # construct version prefix
+    version <- paste(R.version$major, R.version$minor, sep = ".")
+    prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-")
   
     # 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")
-  
-    version
-  
-  }
-  
-  renv_bootstrap_platform_prefix <- function() {
-  
-    # construct version prefix
-    version <- renv_bootstrap_platform_prefix_default()
+      prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r")
   
     # 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))
-      return(FALSE)
-  
-    pattern <- sprintf("^\\Q%s\\E", version)
-    grepl(pattern, expected, perl = TRUE)
-  
+    is.character(expected) && startswith(expected, version)
   }
   
   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
-    patterns <- renv_json_read_patterns()
-    transformed <- text
-    for (pattern in patterns)
-      transformed <- gsub(pattern[[1L]], pattern[[2L]], transformed, fixed = TRUE)
+    # if any are found, replace them with placeholders
+    replaced <- text
+    strings <- character()
+    replacements <- character()
   
-    # parse it
-    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]]
+    if (!identical(c(locs), -1L)) {
   
-    # evaluate in safe environment
-    result <- eval(json, envir = renv_json_read_envir())
+      # get the string values
+      starts <- locs
+      ends <- locs + attr(locs, "match.length") - 1L
+      strings <- substring(text, starts, ends)
   
-    # fix up strings if necessary -- do so only with reversible patterns
-    patterns <- Filter(function(pattern) pattern[[3L]], patterns)
-    renv_json_read_remap(result, patterns)
+      # 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]]
+  
+    # construct map between source strings, replaced strings
+    map <- as.character(parse(text = strings))
+    names(map) <- as.character(parse(text = replacements))
+  
+    # convert to list
+    map <- as.list(map)
+  
+    # 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)