.Rbuildignore

@@ -1,5 +1,3 @@
-^renv$
-^renv\.lock$
 ^.*\.Rproj$
 ^\.Rproj\.user$
 ^\.github$

.github/workflows/rhub.yaml

@@ -1,95 +0,0 @@
-# R-hub's generic GitHub Actions workflow file. It's canonical location is at
-# https://github.com/r-hub/actions/blob/v1/workflows/rhub.yaml
-# You can update this file to a newer version using the rhub2 package:
-#
-# rhub::rhub_setup()
-#
-# It is unlikely that you need to modify this file manually.
-
-name: R-hub
-run-name: "${{ github.event.inputs.id }}: ${{ github.event.inputs.name || format('Manually run by {0}', github.triggering_actor) }}"
-
-on:
-  workflow_dispatch:
-    inputs:
-      config:
-        description: 'A comma separated list of R-hub platforms to use.'
-        type: string
-        default: 'linux,windows,macos'
-      name:
-        description: 'Run name. You can leave this empty now.'
-        type: string
-      id:
-        description: 'Unique ID. You can leave this empty now.'
-        type: string
-
-jobs:
-
-  setup:
-    runs-on: ubuntu-latest
-    outputs:
-      containers: ${{ steps.rhub-setup.outputs.containers }}
-      platforms: ${{ steps.rhub-setup.outputs.platforms }}
-
-    steps:
-    # NO NEED TO CHECKOUT HERE
-    - uses: r-hub/actions/setup@v1
-      with:
-        config: ${{ github.event.inputs.config }}
-      id: rhub-setup
-
-  linux-containers:
-    needs: setup
-    if: ${{ needs.setup.outputs.containers != '[]' }}
-    runs-on: ubuntu-latest
-    name: ${{ matrix.config.label }}
-    strategy:
-      fail-fast: false
-      matrix:
-        config: ${{ fromJson(needs.setup.outputs.containers) }}
-    container:
-      image: ${{ matrix.config.container }}
-
-    steps:
-      - uses: r-hub/actions/checkout@v1
-      - uses: r-hub/actions/platform-info@v1
-        with:
-          token: ${{ secrets.RHUB_TOKEN }}
-          job-config: ${{ matrix.config.job-config }}
-      - uses: r-hub/actions/setup-deps@v1
-        with:
-          token: ${{ secrets.RHUB_TOKEN }}
-          job-config: ${{ matrix.config.job-config }}
-      - uses: r-hub/actions/run-check@v1
-        with:
-          token: ${{ secrets.RHUB_TOKEN }}
-          job-config: ${{ matrix.config.job-config }}
-
-  other-platforms:
-    needs: setup
-    if: ${{ needs.setup.outputs.platforms != '[]' }}
-    runs-on: ${{ matrix.config.os }}
-    name: ${{ matrix.config.label }}
-    strategy:
-      fail-fast: false
-      matrix:
-        config: ${{ fromJson(needs.setup.outputs.platforms) }}
-
-    steps:
-      - uses: r-hub/actions/checkout@v1
-      - uses: r-hub/actions/setup-r@v1
-        with:
-          job-config: ${{ matrix.config.job-config }}
-          token: ${{ secrets.RHUB_TOKEN }}
-      - uses: r-hub/actions/platform-info@v1
-        with:
-          token: ${{ secrets.RHUB_TOKEN }}
-          job-config: ${{ matrix.config.job-config }}
-      - uses: r-hub/actions/setup-deps@v1
-        with:
-          job-config: ${{ matrix.config.job-config }}
-          token: ${{ secrets.RHUB_TOKEN }}
-      - uses: r-hub/actions/run-check@v1
-        with:
-          job-config: ${{ matrix.config.job-config }}
-          token: ${{ secrets.RHUB_TOKEN }}

CRAN-SUBMISSION

@@ -0,0 +1,3 @@
+Version: 23.4.1
+Date: 2023-04-13 11:57:00 UTC
+SHA: 86bb9dc95357d5861603e3d487b59e1761edcded

DESCRIPTION

@@ -1,11 +1,11 @@
 Package: stRoke
 Title: Clinical Stroke Research
-Version: 24.10.1
+Version: 23.6.3
 Authors@R: 
     person("Andreas Gammelgaard", "Damsbo", , "agdamsbo@clin.au.dk", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0002-7559-1154"))
-Description: A collection of tools for clinical trial data management and 
+Description: This is an R-toolbox of custom functions for convenient data management 
-    analysis in research and teaching.
+    and analysis in clinical health research and teaching.
     The package is mainly collected for personal use, but any use beyond that is encouraged.
     This package has migrated functions from 'agdamsbo/daDoctoR', and new functions has been added.
     Version follows months and year. See NEWS/Changelog for release notes.
@@ -17,18 +17,16 @@ BugReports: https://github.com/agdamsbo/stRoke/issues
 License: GPL-3
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.2
+RoxygenNote: 7.2.3
 LazyData: true
 Suggests:
+    covr,
+    devtools,
     knitr,
     rmarkdown,
-    testthat,
-    here,
     spelling,
-    usethis,
+    testthat (>= 3.0.0)
-    pak,
+Language: en-US
-    roxygen2,
-    devtools
 Config/testthat/edition: 3
 Imports: 
     calendar,
@@ -41,10 +39,7 @@ Imports:
     rankinPlot,
     stats,
     tidyr,
-    utils,
+    utils
-    tibble,
-    tidyselect
 Depends: 
     R (>= 2.10)
 VignetteBuilder: knitr
-Language: en-US

NAMESPACE

@@ -1,9 +1,7 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(print,win_Prob)
-export(add_padding)
 export(age_calc)
-export(chunks_of_n)
 export(ci_plot)
 export(color_plot)
 export(contrast_text)
@@ -15,12 +13,9 @@ export(files_filter)
 export(generic_stroke)
 export(index_plot)
 export(label_select)
-export(mfi_domains)
-export(n_chunks)
 export(pase_calc)
 export(quantile_cut)
 export(source_lines)
-export(str_extract)
 export(win_prob)
 export(write_ical)
 import(ggplot2)

NEWS.md

@@ -1,32 +1,3 @@
-# stRoke 24.10.1
-
-This version marks a significant change in the contents and focus of this package. Going forward I will include functions with a focus on handling clinical trial data from my own stroke research.
-Other functions for general data management an project management has been migrated to the [`project.aid`](https://agdamsbo.github.io/project.aid/) package, which is moving towards CRAN submission. Install dev-version with `pak::pak("agdamsbo/project.aid")`.
-
-### Functions:
-
-* UPDATE: `pase_calc()` updated for uniform column naming in output as well as streamlining the function a bit.
-
-* Moving: The following functions are moved to `agdamsbo/project.aid` to focus on (stroke) trial related functions: `str_extract()`, `add_padding()`, `age_calc()`, `chunks_of_n()`, `contrast_text()`, `files_filter()`, `quantile_cut()`, `write_ical()`.
-
-* NEW: `mfi_calc()` calculates domain scores from the MFI questionnaire. Takes data frame of 20 ordered as the questionnaire. Default is to reverse questions with reverse scoring.
-
-Checks set up with `rhub` v2
-
-# stRoke 23.9.1
-
-### Functions:
-
-* NEW: `chunks_of_n()` uses `split()` to separate supplied vector or data frame into chunks of n. Flags to set if all but the last chunks should be exactly size n, or if they should be evenly sized of max n. Labels can be provided including regex pattern for subject naming to include in chunk names.
-
-* NEW: `n_chunks()` is the opposite of `chunks_of_n()` and is simply a wrapper for this function to create list of n chunks based of provided vector or data frame.
-
-* NEW: `str_extract()` will extract the substring of a character string given by a regex pattern. Came to be as a helper function for labelling chunks in `chunks_of_n()`, but will be useful on its own. Other functions doing the same exists, but this is my take only using base _R_. Draws on `REDCapCAST::strsplitx()`, where splits can be performed around a pattern.
-
-* NEW: `add_padding()` was created out of frustration. I wanted to add padding using `sprintf("%0s",string)`, in examples for the above, but it would fail when rendering on Windows. Say hello to another function. Just very small. Defaults to adding leading zeros, to get all string to equal length with the longer string supplied.
-
-* Deprecation: `ds2dd()` moved to `REDCapCAST::ds2dd()` as this is where it belongs.
-
 # stRoke 23.6.3
 
 ### Bug

R/add_padding.R

@@ -1,43 +0,0 @@
-#' MOVED Add padding to string
-#'
-#' @param d vector of strings or numbers
-#' @param length final string length
-#' @param after if padding should be added after as opposed to default before
-#' @param pad padding string of length 1
-#' @param lead leading string for all. Number or character vector. Cycled.
-#' @param tail tailing string for all. Number or character vector. Cycled.
-#'
-#' @return vector or character strings of same length.
-#' @export
-#'
-#' @examples
-#' add_padding(sample(1:200,5),tail="AA",lead=c(2,3,"e"))
-add_padding <- function(d,length=NULL,after=FALSE,pad="0",lead=NULL,tail=NULL){
-  if (!is.vector(d)) {
-    stop("Please supply vector")
-  }
-  
-  if (nchar(pad)!=1) {
-    stop("Padding value should be just a single character or digit")
-  }
-  
-  ns <- nchar(d)
-  
-  if (is.null(length)){
-    l <- max(ns)
-  } else {
-    l <- length
-  }
-  
-  ps <- unlist(lapply(l-ns,function(i){
-    paste(rep(pad,i),collapse="")}))
-  
-  if (after) {
-    out <- paste0(d,ps)
-  } else {
-    out <- paste0(ps,d)
-  }
-  
-  paste0(lead,out,tail)
-
-}

R/chunks_of_n.R

@@ -1,84 +0,0 @@
-#' MOVED Split to chunks of size n
-#'
-#' @param d data. Can be vector or data frame.
-#' @param n number of chunks
-#' @param label naming prefix for chunk names
-#' @param even boolean to set if size of chunks should be evenly distributed.
-#' @param pattern regex pattern to extract names from provided vector. If data
-#' frame, will assume first column is name.
-#'
-#' @return List of length n
-#' @export
-#'
-#' @examples
-#' tail(chunks_of_n(seq_len(100),7),3)
-#' tail(chunks_of_n(seq_len(100),7,even=TRUE),3)
-#' ds <- data.frame(nm=paste0("Sub",
-#' add_padding(rownames(stRoke::talos))),stRoke::talos)
-#' head(chunks_of_n(ds,7,pattern="Sub[0-9]{3}",label="grp"),2)
-#' ## Please notice that no sorting is performed. This is on purpose to preserve
-#' ## original sorting. If sorting is intended, try something like this:
-#' ds[order(ds$nm),] |> chunks_of_n(7,pattern="Sub[0-9]{3}",label="grp") |> 
-#' head(2)
-
-chunks_of_n <- function(d,n,label=NULL, even=FALSE, pattern=NULL){
-  
-  if (!(is.vector(d) |
-        is.data.frame(d)) |
-      inherits(d,"list")) {
-    stop("Provided data is not vector or data.frame.")
-  }
-  
-  if (is.data.frame(d)) ns <- nrow(d) else ns <- length(d) 
-  
-  if (even) {
-    g <- sort(rep_len(seq_len(ceiling(ns / n)), ns))
-  } else {
-    g <- ceiling(seq_len(ns) / n)
-  }
-  
-  ls <- split(d, g)
-  
-  if (!is.null(pattern)) {
-    if(is.data.frame(d)) {
-      ns <- str_extract(d=d[[1]],pattern=pattern)
-      } else ns <- str_extract(d=d,pattern=pattern)
-    
-    
-    suffix <- do.call(c, lapply(split(ns, g), function(i) {
-      paste0(i[[1]], "-", i[[length(i)]])
-    }))
-  } else suffix <- names(ls)
-  
-  if (is.character(label)){
-    names(ls) <- paste0(label,"-",suffix)
-    } else names(ls) <- suffix
-  
-  ls
-}
-
-#' Splits in n chunks
-#'
-#' @param d data
-#' @param n number of chunks
-#' @param ... arguments passed to internal `chunks_of_n()`
-#'
-#' @return List of chunks
-#' @export
-#'
-#' @examples
-#' lengths(n_chunks(d=seq_len(100),n=7,even=TRUE))
-#' lengths(n_chunks(d=seq_len(100),n=7,even=FALSE))
-n_chunks <- function(d,n,...){
-  if (!(is.vector(d) |
-        is.data.frame(d)) |
-      inherits(d,"list")) {
-    stop("Provided data is not vector or data.frame.")
-  }
-  
-  if (is.data.frame(d)) ns <- nrow(d) else ns <- length(d) 
-  
-  nn <- ceiling(ns/n)
-  
-  chunks_of_n(d=d,n=nn,...)
-}

R/ci_plot.R

@@ -42,8 +42,8 @@ ci_plot <-
            title = NULL, 
            method = "auto") {
     
-    if (!method %in% c("auto", "model")){
+    if (!method %in% c("auto", "model"))
-      stop("Method has to either 'auto' or 'model'")}
+      stop("Method has to either 'auto' or 'model'")
     
     if (method == "auto") {
       if (!is.factor(ds[, y]))

R/contrast_text.R

@@ -1,4 +1,6 @@
-#' MOVED Contrast Text Color
+
+
+#' @title Contrast Text Color
 #' @description Calculates the best contrast text color for a given 
 #' background color.
 #' @param background A hex/named color value that represents the background.

R/ds2dd.R

@@ -1,5 +1,5 @@
 utils::globalVariables(c("metadata_names"))
-#' *DEPRECATED* Moved to REDCapCAST::ds2dd() | Data set to data dictionary function
+#' Data set to data dictionary function
 #'
 #' @param ds data set
 #' @param record.id name or column number of id variable, moved to first row of 

R/files_filter.R

@@ -1,6 +1,6 @@
 
 
-#' MOVED Filter files in a folder
+#' @title Filter files in a folder
 #' @description This function filters files in a folder based on the 
 #' provided filter.
 #' @param folder.path character. Path of the folder to be filtered

R/generic_stroke.R

@@ -36,13 +36,13 @@ generic_stroke <-
       gtsummary::add_overall()
     
     x <- table(df[, c(group, score, strata)])
-    f1 <- suppressWarnings(rankinPlot::grottaBar(
+    f1 <- rankinPlot::grottaBar(
       x = x,
       groupName = group,
       scoreName = score,
       strataName = strata,
       colourScheme = "custom"
-    ))
+    )
     
     df[, score] <- factor(df[, score], ordered = TRUE)
     

R/metadata.R

@@ -5,7 +5,7 @@
 #' \describe{
 #'   \item{metadata_names}{characterstrings}
 #' }
-#' @seealso project-redcap(dot)org (currently the certificate is broken)
+#' @seealso \url{https://www.project-redcap.org/}
 #' @usage data(metadata_names)
 "metadata_names"
 

R/mfi_calc.R

@@ -1,80 +0,0 @@
-utils::globalVariables(c("ndx"))
-#' Reverses relevant MFI subscores
-#'
-#' @param d data frame or tibble
-#' @param var numeric vector of indices of columns to reverse
-#'
-#' @return data.frame or tibble depending on input
-#'
-#' @examples
-#' # rep_len(sample(1:5),length.out = 100) |> matrix(ncol=10) |> multi_rev(2:4)
-multi_rev <- function(d, var){
-  # Forcing and coercing to numeric
-  dm <- d |> as.matrix() |> 
-    as.numeric()|> 
-    matrix(ncol=ncol(d)) |> 
-    data.frame()
-  
-  # Reversing everything (fast enough not to subset)
-  dr <- range(dm,na.rm=TRUE) |> sum()-dm
-  
-  # Inserting reversed scores in correct places
-  for (i in var){
-    dm[i] <- dr[i]
-  }
-  
-  if (tibble::is_tibble(d)){
-    tibble::tibble(dm)
-  } else {
-      dm
-    }
-
-}
-
-#' MFI domain score calculator
-#'
-#' @param ds data set of MFI scores, 20 columns
-#' @param reverse.vars variables/columns to reverse
-#' @param reverse reverse scoring
-#'
-#' @return tibble of domain scores
-#' @export
-#'
-#' @examples
-#' mfi_mess <- data.frame(matrix(
-#' sample(c(" 1. ", "2. -A", "3.", " 4  ", "5.", NA),200,replace=TRUE),ncol=20))
-#' mfi_mess |> mfi_domains()
-mfi_domains <-
-  function(ds,
-           reverse = TRUE,
-           reverse.vars = c(2, 5, 9, 10, 13, 14, 16, 17, 18, 19)) {
-    
-  if(ncol(ds)!=20){
-    stop("The supplied dataset should only contain the 20 MFI subscores")}
-  
-  # Subscore indexes
-  indexes <- list(
-    data.frame(grp="gen", ndx=c(1, 5, 12, 16)),
-    data.frame(grp="phy", ndx=c(2, 8, 14, 20)),
-    data.frame(grp="act", ndx=c(3, 6, 10, 17)),
-    data.frame(grp="mot", ndx=c(4, 9, 15, 18)),
-    data.frame(grp="men", ndx=c(7, 11, 13, 19))
-  ) |> dplyr::bind_rows() |> dplyr::arrange(ndx)
-  
-  # Removes padding and converts to numeric
-  ds_n <- ds |> dplyr::mutate_if(is.factor, as.character) |> 
-    dplyr::mutate(dplyr::across(tidyselect::everything(),
-                  # Removes everything but the leading alphanumeric character
-                  # Data should be cleaned accordingly
-                  ~str_extract(d=.,pattern="[[:alnum:]]")))
-  
-  # Assumes reverse scores are not correctly reversed
-  if (reverse){ds_n <- ds_n |> multi_rev(var=reverse.vars)}
-  
-  # Domain wise summations
-  split.default(ds_n, factor(indexes$grp)) |> 
-    lapply(function(x){
-      apply(x, MARGIN = 1, sum, na.ignore=FALSE)
-    }) |> dplyr::bind_cols()
-  
-  }

R/pase_calc.R

@@ -3,7 +3,6 @@
 #' Calculates PASE score from raw questionnaire data.
 #' @param ds data set
 #' @param adjust_work flag to set whether to include 10b type 1. 
-#' @param consider.missing character vector of values considered missing.
 #' Default is TRUE.
 #'
 #' @return data.frame
@@ -28,16 +27,10 @@
 #' 
 #' @examples
 #' summary(pase_calc(stRoke::pase)[,13])
-#' str(pase_calc(stRoke::pase))
 #' 
-pase_calc <- function(ds, 
+pase_calc <- function(ds, adjust_work = FALSE) {
-                      adjust_work = FALSE, 
-                      consider.missing = c("Not available")) {
   
-  if (ncol(ds) != 21) {
+  if (ncol(ds) != 21) stop("supplied data set has to contain exactly 21 columns")
-    stop("supplied data set has to contain exactly 21 columns.
-         Formatting should follow the stRoke::pase data set.")
-    }
   
   pase <- ds
   
@@ -48,20 +41,10 @@ pase_calc <- function(ds,
   pase <- do.call(data.frame, lapply(pase, as.character))
   
   ## Missings and incompletes
-  # Cosidered missing if all data is missing
   missings <- apply(apply(ds, 2, is.na), 1, all)
-  
-  # Considered incomplete if any entry in main answers is missing
-  mains <- grep("([0-9]{2}|(09[a-d]))$",colnames(pase))
-  
-  if (length(mains)!=13){
-    stop("The supplied dataset does not contain expected variable names.
-         Please run str(stRoke::pase) and format your data accordingly.")
-    }
-  
   incompletes <-
-    apply(sapply(ds[, mains], function(x) {
+    apply(sapply(ds[, c(1, 3, 5, 7, 9, 11, 13:20)], function(x) {
-      x %in% consider.missing | is.na(x)
+      x == "Not available" | is.na(x)
     }), 1, any)
   
   names(pase) <- c(
@@ -95,7 +78,7 @@ pase_calc <- function(ds,
   
   ## PASE 2-6
   
-  pase_weights <- list(
+  pase_weigths <- list(
     "1" = c(
       "1" = 0.11,
       "2" = 0.32,
@@ -121,45 +104,37 @@ pase_calc <- function(ds,
   
   pase_score_26 <- lapply(seq_along(pase_list[2:6]), function(x) {
     df <- pase_list[2:6][[x]]
-    # score <- c()
+    score <- c()
     
     ## =====================
     ## Checking labelling
-    if (!all(stRoke::str_extract(df[, 1], "^[0-3]") |> 
+    if (!all(range(suppressWarnings(as.numeric(substr(
-             as.numeric() |> 
+      df[, 1], 1, 1
-             range(na.rm = TRUE) == c(0, 3))) {
+    ))), na.rm = TRUE) == c(0, 3))) {
-      stop("Labelling of 02-06 should start with a number ranging 0-3")
+      stop("Labelling of 02-06 should start with a number ranging 1-4")
     }
-    
-    if (!all(stRoke::str_extract(df[, 2], "^[1-4]") |> 
-             as.numeric() |> 
-             range(na.rm = TRUE) == c(1, 4))) {
-      stop("Labelling of 02-06 subscores should start with a number ranging 1-4")
-    }
-    
     ## =====================
     
-    ## Extracting the first string element in main entry
+    for (i in seq_len(nrow(df))) {
-    n1 <- stRoke::str_extract(df[, 1],"^[0-3]") |> as.numeric()
+      # Setting categories from numbers
-    ## Extracting the first string element in subentry
+      n1 <- suppressWarnings(as.numeric(substr(df[, 1][i], 1, 1)))
-    n2 <- stRoke::str_extract(df[, 2],"^[1-4]") |> as.numeric()
       
-    score <- c()
+      # Using if statement to calculate row wise
-    for (i in seq_along(n1)) {
+      if (n1 %in% c(1:3)) {
+        # Second category
+        n2 <- suppressWarnings(as.numeric(substr(df[, 2][i], 1, 1)))
+        score[i] <- pase_weigths[[n1]][n2] * pase_multip_26[x] 
         
-      ind1 <- match(n1[i],seq_along(pase_weights))
+      } else if (n1 %in% 0) {
-      
+        score[i] <- 0
-      if (is.na(ind1)){
-        score[i] <- n1[i]
       } else {
-        score[i] <- pase_weights[[ind1]][n2[i]] * pase_multip_26[x] 
+        score[i] <- NA
       }
-      
     }
     score
   })
   
-  names(pase_score_26) <- paste0("pase_score_", names(pase_list[2:6]))
+  names(pase_score_26) <- paste0("score_", names(pase_list[2:6]))
   
   ## PASE 7-9d
   pase_multip_79 <- c(25, 25, 30, 36, 20, 35)
@@ -172,7 +147,7 @@ pase_calc <- function(ds,
     ) * pase_multip_79))
   
   names(pase_score_79) <-
-    paste0("pase_score_", sub("pase","",names(pase_score_79)))
+    paste0("score_", sub("pase", "", names(pase_score_79)))
   
   ## PASE 10
   ## Completely ignores if 10b is not completed
@@ -182,15 +157,15 @@ pase_calc <- function(ds,
     # Only includes work time if 10b is != 1
     pase_score_10[substr(pase_list[[10]][[3]],1,1) == "1"] <- 0
     # Consequently consider "Not available" in 10b as incomplete
-    incompletes[ds[,21] %in% consider.missing & !incompletes & !is.na(incompletes)] <- TRUE
+    incompletes[ds[,21] == "Not available" & !incompletes & !is.na(incompletes)] <- TRUE
   }
   
   pase_score <- cbind(pase_score_26, pase_score_79, pase_score_10)
   
   data.frame(
     pase_score,
-    pase_score_sum = rowSums(pase_score, na.rm = TRUE),
+    score_sum = rowSums(pase_score, na.rm = TRUE),
-    pase_score_missings = missings,
+    score_missings = missings,
-    pase_score_incompletes = incompletes
+    score_incompletes = incompletes
   )
 }

R/quantile_cut.R

@@ -1,4 +1,4 @@
-#' MOVED Easy function for splitting numeric variable in quantiles
+#' Easy function for splitting numeric variable in quantiles
 #'
 #' Using base/stats functions cut() and quantile().
 #'

R/str_extract.R

@@ -1,39 +0,0 @@
-#' Extract string based on regex pattern
-#' 
-#' DEPRECATION: moved to `agdamsbo/project.aid`
-#' 
-#' Use base::strsplit to 
-#' @param d vector of character strings
-#' @param pattern regex pattern to match
-#'
-#' @return vector of character strings
-#' @export
-#'
-#' @examples
-#' ls <- do.call(c,lapply(sample(4:8,20,TRUE),function(i){
-#' paste(sample(letters,i,TRUE),collapse = "")}))
-#' ds <- do.call(c,lapply(1:20,function(i){
-#' paste(sample(ls,1),i,sample(ls,1),"23",sep = "_")}))
-#' str_extract(ds,"([0-9]+)")
-str_extract <- function(d,pattern){
-  if (!is.vector(d)) stop("Please provide a vector")
-  
-  ## Drawing on the solution in REDCapCAST::strsplitx to split around pattern
-  nl <- strsplit(gsub("~~", "~", # Removes double ~
-                      gsub("^~", "", # Removes leading ~
-                           gsub(
-                             # Splits and inserts ~ at all delimiters
-                             paste0("(", pattern, ")"), "~\\1~", d
-                           ))), "~")
-  
-  ## Reusing the pattern, to sub with "" and match on length 0 to index the
-  ## element containing the pattern. Only first occurance included.
-  indx <- lapply(nl,function(i){
-    match(0,nchar(sub(pattern,"",i)))
-    })
-  
-  ## Using lapply to subsset the given index for each element in list
-  do.call(c,lapply(seq_along(nl), function(i){
-    nl[[i]][indx[[i]]]
-  } ))
-}

R/write_ical.R

@@ -1,6 +1,6 @@
 
 
-#' MOVED Write ical object
+#' Write ical object
 #' 
 #' This function creates an ical file based on a data frame with mixed events. 
 #' Export as .ics file using `calendar::ic_write()`.

README.md

@@ -6,6 +6,7 @@
 [![Page deployed](https://github.com/agdamsbo/stRoke/actions/workflows/pages/pages-build-deployment/badge.svg)](https://github.com/agdamsbo/stRoke/actions/workflows/pages/pages-build-deployment)
 [![Codecov test coverage](https://codecov.io/gh/agdamsbo/stRoke/branch/main/graph/badge.svg)](https://app.codecov.io/gh/agdamsbo/stRoke?branch=main)
 [![CRAN downloads](https://cranlogs.r-pkg.org/badges/grand-total/stRoke)](https://cran.r-project.org/package=stRoke)
+[![R-CMD-check](https://github.com/agdamsbo/stRoke/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/agdamsbo/stRoke/actions/workflows/R-CMD-check.yaml)
 <!-- badges: end -->
 
 # stRoke package <img src="man/figures/logo.png" align="right" />

codecov.yml

@@ -5,10 +5,10 @@ coverage:
     project:
       default:
         target: auto
-        threshold: .1%
+        threshold: 1%
         informational: true
     patch:
       default:
         target: auto
-        threshold: .1%
+        threshold: 1%
         informational: true

cran-comments.md

@@ -1,6 +1,49 @@
-── R CMD check results ───────────────────────────────────────────────────────────────────────── stRoke 24.10.1 ────
+## R CMD check results
-Duration: 28.4s
 
-0 errors ✔ | 0 warnings ✔ | 0 notes ✔
+0 errors | 0 warnings | 1 note
 
-R CMD check succeeded
+* This is a new release.
+
+## From 'rhub::check_for_cran()'
+
+> results
+
+── stRoke 23.6.3: NOTE
+
+  Build ID:   stRoke_23.6.3.tar.gz-02460c19f45e403eb1b115ac763abc6d
+  Platform:   Windows Server 2022, R-devel, 64 bit
+  Submitted:  1h 56m 49.6s ago
+  Build time: 5m 11.1s
+
+❯ checking for non-standard things in the check directory ... NOTE
+  
+
+❯ checking for detritus in the temp directory ... NOTE
+  Found the following files/directories:
+    'lastMiKTeXException'
+
+0 errors ✔ | 0 warnings ✔ | 2 notes ✖
+
+── stRoke 23.6.3: NOTE
+
+  Build ID:   stRoke_23.6.3.tar.gz-d174f9de31a94b81b697dd9c28bcdf9f
+  Platform:   Ubuntu Linux 20.04.1 LTS, R-release, GCC
+  Submitted:  1h 56m 49.7s ago
+  Build time: 1h 20m 33.6s
+
+❯ checking HTML version of manual ... NOTE
+  Skipping checking HTML validation: no command 'tidy' found
+
+0 errors ✔ | 0 warnings ✔ | 1 note ✖
+
+── stRoke 23.6.3: NOTE
+
+  Build ID:   stRoke_23.6.3.tar.gz-22dfd84a4ab244f6ae09928a12737bf0
+  Platform:   Fedora Linux, R-devel, clang, gfortran
+  Submitted:  1h 56m 49.7s ago
+  Build time: 1h 12m 16s
+
+❯ checking HTML version of manual ... NOTE
+  Skipping checking HTML validation: no command 'tidy' found
+
+0 errors ✔ | 0 warnings ✔ | 1 note ✖

data-raw/cprs.R

@@ -5,4 +5,4 @@ usethis::use_data(cprs, overwrite = TRUE)
 cprs <- data.frame(cpr=sample(c("2310450637", "010115-4000", "0101896000",
                                 "010189-3000","300450-1030","010150-4021",
                                 "011085-AKE3","0101EJ-ATW3"),200,TRUE))
-save(cprs,file="data/cprs.rda")
+save(cprs,file="cprs.rda")

inst/WORDLIST

@@ -1,21 +1,23 @@
 Andreas
+CMD
 Changelog
 Codecov
 DDMMYY
 DOI
+DataDictionary
 Gammelgaard
 Github
 Kraglund
 Labelling
 METACRAN
-MFI
 NA's
 OLR
 ORCID
+OpenAI's
 PASE
 REDCap
-REDCapCAST
 REDCapRITS
+RStudio
 Randomisation
 STROKEAHA
 StackOverflow
@@ -27,10 +29,11 @@ XXXX
 Zou
 agdamsbo
 al
-anonymized
+annonymized
 bstfun
 calc
 characterstrings
+chatgpt
 christophergandrud
 ci
 codecov
@@ -41,7 +44,6 @@ cprs
 daDoctoR
 ddmmyy
 ddmmyyxxxx
-dev
 difftime
 dk
 doi
@@ -66,7 +68,6 @@ ics
 inteRgrate
 jan
 jss
-labelling
 lm
 lst
 luminance
@@ -77,10 +78,7 @@ rect
 rgb
 sapply
 stackoverflow
-strsplit
-subscores
 teppo
-tibble
 vapply
 vec
 winP

man/add_padding.Rd

@@ -1,37 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/add_padding.R
-\name{add_padding}
-\alias{add_padding}
-\title{MOVED Add padding to string}
-\usage{
-add_padding(
-  d,
-  length = NULL,
-  after = FALSE,
-  pad = "0",
-  lead = NULL,
-  tail = NULL
-)
-}
-\arguments{
-\item{d}{vector of strings or numbers}
-
-\item{length}{final string length}
-
-\item{after}{if padding should be added after as opposed to default before}
-
-\item{pad}{padding string of length 1}
-
-\item{lead}{leading string for all. Number or character vector. Cycled.}
-
-\item{tail}{tailing string for all. Number or character vector. Cycled.}
-}
-\value{
-vector or character strings of same length.
-}
-\description{
-MOVED Add padding to string
-}
-\examples{
-add_padding(sample(1:200,5),tail="AA",lead=c(2,3,"e"))
-}

man/chunks_of_n.Rd

@@ -1,37 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/chunks_of_n.R
-\name{chunks_of_n}
-\alias{chunks_of_n}
-\title{MOVED Split to chunks of size n}
-\usage{
-chunks_of_n(d, n, label = NULL, even = FALSE, pattern = NULL)
-}
-\arguments{
-\item{d}{data. Can be vector or data frame.}
-
-\item{n}{number of chunks}
-
-\item{label}{naming prefix for chunk names}
-
-\item{even}{boolean to set if size of chunks should be evenly distributed.}
-
-\item{pattern}{regex pattern to extract names from provided vector. If data
-frame, will assume first column is name.}
-}
-\value{
-List of length n
-}
-\description{
-MOVED Split to chunks of size n
-}
-\examples{
-tail(chunks_of_n(seq_len(100),7),3)
-tail(chunks_of_n(seq_len(100),7,even=TRUE),3)
-ds <- data.frame(nm=paste0("Sub",
-add_padding(rownames(stRoke::talos))),stRoke::talos)
-head(chunks_of_n(ds,7,pattern="Sub[0-9]{3}",label="grp"),2)
-## Please notice that no sorting is performed. This is on purpose to preserve
-## original sorting. If sorting is intended, try something like this:
-ds[order(ds$nm),] |> chunks_of_n(7,pattern="Sub[0-9]{3}",label="grp") |> 
-head(2)
-}

man/contrast_text.Rd

@@ -2,7 +2,7 @@
 % Please edit documentation in R/contrast_text.R
 \name{contrast_text}
 \alias{contrast_text}
-\title{MOVED Contrast Text Color}
+\title{Contrast Text Color}
 \usage{
 contrast_text(
   background,

man/ds2dd.Rd

@@ -2,7 +2,7 @@
 % Please edit documentation in R/ds2dd.R
 \name{ds2dd}
 \alias{ds2dd}
-\title{\emph{DEPRECATED} Moved to REDCapCAST::ds2dd() | Data set to data dictionary function}
+\title{Data set to data dictionary function}
 \usage{
 ds2dd(
   ds,
@@ -40,7 +40,7 @@ stRoke::metadata_names.}
 data.frame or list of data.frame and vector
 }
 \description{
-\emph{DEPRECATED} Moved to REDCapCAST::ds2dd() | Data set to data dictionary function
+Data set to data dictionary function
 }
 \examples{
 talos$id <- seq_len(nrow(talos))

man/files_filter.Rd

@@ -2,7 +2,7 @@
 % Please edit documentation in R/files_filter.R
 \name{files_filter}
 \alias{files_filter}
-\title{MOVED Filter files in a folder}
+\title{Filter files in a folder}
 \usage{
 files_filter(folder.path, filter.by, full.names = TRUE)
 }

man/metadata_names.Rd

@@ -17,6 +17,6 @@ data(metadata_names)
 Vector of REDCap metadata headers
 }
 \seealso{
-project-redcap(dot)org (currently the certificate is broken)
+\url{https://www.project-redcap.org/}
 }
 \keyword{datasets}

man/mfi_domains.Rd

@@ -1,30 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/mfi_calc.R
-\name{mfi_domains}
-\alias{mfi_domains}
-\title{MFI domain score calculator}
-\usage{
-mfi_domains(
-  ds,
-  reverse = TRUE,
-  reverse.vars = c(2, 5, 9, 10, 13, 14, 16, 17, 18, 19)
-)
-}
-\arguments{
-\item{ds}{data set of MFI scores, 20 columns}
-
-\item{reverse}{reverse scoring}
-
-\item{reverse.vars}{variables/columns to reverse}
-}
-\value{
-tibble of domain scores
-}
-\description{
-MFI domain score calculator
-}
-\examples{
-mfi_mess <- data.frame(matrix(
-sample(c(" 1. ", "2. -A", "3.", " 4  ", "5.", NA),200,replace=TRUE),ncol=20))
-mfi_mess |> mfi_domains()
-}

man/multi_rev.Rd

@@ -1,22 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/mfi_calc.R
-\name{multi_rev}
-\alias{multi_rev}
-\title{Reverses relevant MFI subscores}
-\usage{
-multi_rev(d, var)
-}
-\arguments{
-\item{d}{data frame or tibble}
-
-\item{var}{numeric vector of indices of columns to reverse}
-}
-\value{
-data.frame or tibble depending on input
-}
-\description{
-Reverses relevant MFI subscores
-}
-\examples{
-# rep_len(sample(1:5),length.out = 100) |> matrix(ncol=10) |> multi_rev(2:4)
-}

man/n_chunks.Rd

@@ -1,25 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/chunks_of_n.R
-\name{n_chunks}
-\alias{n_chunks}
-\title{Splits in n chunks}
-\usage{
-n_chunks(d, n, ...)
-}
-\arguments{
-\item{d}{data}
-
-\item{n}{number of chunks}
-
-\item{...}{arguments passed to internal \code{chunks_of_n()}}
-}
-\value{
-List of chunks
-}
-\description{
-Splits in n chunks
-}
-\examples{
-lengths(n_chunks(d=seq_len(100),n=7,even=TRUE))
-lengths(n_chunks(d=seq_len(100),n=7,even=FALSE))
-}

man/pase_calc.Rd

@@ -4,14 +4,12 @@
 \alias{pase_calc}
 \title{PASE score calculator}
 \usage{
-pase_calc(ds, adjust_work = FALSE, consider.missing = c("Not available"))
+pase_calc(ds, adjust_work = FALSE)
 }
 \arguments{
 \item{ds}{data set}
 
-\item{adjust_work}{flag to set whether to include 10b type 1.}
+\item{adjust_work}{flag to set whether to include 10b type 1.
-
-\item{consider.missing}{character vector of values considered missing.
 Default is TRUE.}
 }
 \value{
@@ -43,6 +41,5 @@ set \code{TRUE}.
 }
 \examples{
 summary(pase_calc(stRoke::pase)[,13])
-str(pase_calc(stRoke::pase))
 
 }

man/quantile_cut.Rd

@@ -2,7 +2,7 @@
 % Please edit documentation in R/quantile_cut.R
 \name{quantile_cut}
 \alias{quantile_cut}
-\title{MOVED Easy function for splitting numeric variable in quantiles}
+\title{Easy function for splitting numeric variable in quantiles}
 \usage{
 quantile_cut(
   x,

man/stRoke-package.Rd

@@ -8,7 +8,7 @@
 \description{
 \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}}
 
-A collection of tools for clinical trial data management and analysis in research and teaching. The package is mainly collected for personal use, but any use beyond that is encouraged. This package has migrated functions from 'agdamsbo/daDoctoR', and new functions has been added. Version follows months and year. See NEWS/Changelog for release notes. This package includes sampled data from the TALOS trial (Kraglund et al (2018) \doi{10.1161/STROKEAHA.117.020067}). The win_prob() function is based on work by Zou et al (2022) \doi{10.1161/STROKEAHA.121.037744}. The age_calc() function is based on work by Becker (2020) \doi{10.18637/jss.v093.i02}.
+This is an R-toolbox of custom functions for convenient data management and analysis in clinical health research and teaching. The package is mainly collected for personal use, but any use beyond that is encouraged. This package has migrated functions from 'agdamsbo/daDoctoR', and new functions has been added. Version follows months and year. See NEWS/Changelog for release notes. This package includes sampled data from the TALOS trial (Kraglund et al (2018) \doi{10.1161/STROKEAHA.117.020067}). The win_prob() function is based on work by Zou et al (2022) \doi{10.1161/STROKEAHA.121.037744}. The age_calc() function is based on work by Becker (2020) \doi{10.18637/jss.v093.i02}.
 }
 \seealso{
 Useful links:

man/str_extract.Rd

@@ -1,29 +0,0 @@
-% Generated by roxygen2: do not edit by hand
-% Please edit documentation in R/str_extract.R
-\name{str_extract}
-\alias{str_extract}
-\title{Extract string based on regex pattern}
-\usage{
-str_extract(d, pattern)
-}
-\arguments{
-\item{d}{vector of character strings}
-
-\item{pattern}{regex pattern to match}
-}
-\value{
-vector of character strings
-}
-\description{
-DEPRECATION: moved to \code{agdamsbo/project.aid}
-}
-\details{
-Use base::strsplit to
-}
-\examples{
-ls <- do.call(c,lapply(sample(4:8,20,TRUE),function(i){
-paste(sample(letters,i,TRUE),collapse = "")}))
-ds <- do.call(c,lapply(1:20,function(i){
-paste(sample(ls,1),i,sample(ls,1),"23",sep = "_")}))
-str_extract(ds,"([0-9]+)")
-}

man/write_ical.Rd

@@ -2,7 +2,7 @@
 % Please edit documentation in R/write_ical.R
 \name{write_ical}
 \alias{write_ical}
-\title{MOVED Write ical object}
+\title{Write ical object}
 \usage{
 write_ical(
   df,

stRoke.Rproj

@@ -15,4 +15,4 @@ LaTeX: pdfLaTeX
 BuildType: Package
 PackageUseDevtools: Yes
 PackageInstallArgs: --no-multiarch --with-keep.source
-PackageRoxygenize: rd,collate,namespace,vignette
+PackageRoxygenize: rd,collate,namespace

tests/spelling.R

@@ -0,0 +1,3 @@
+if(requireNamespace('spelling', quietly = TRUE))
+  spelling::spell_check_test(vignettes = TRUE, error = FALSE,
+                             skip_on_cran = TRUE)

tests/testthat/test-age_calc.R

@@ -0,0 +1,72 @@
+test_that("age_calc works for vectors of length 1 (scalars)", {
+  result <- age_calc(as.Date("1945-10-23"), as.Date("2018-09-30"))
+  expect_equal(round(result), 73)
+})
+
+################################################################################
+
+# Unit Test - gpttools
+
+test_that("age_calc works correctly for years", {
+  expect_equal(age_calc(as.Date("2000-01-01"), as.Date("2020-01-01"),
+                        units = "years"), 20)
+})
+
+test_that("age_calc gives error if enddate < dob", {
+  expect_error(age_calc(as.Date("2020-01-01"), as.Date("2000-01-01"),
+                        units = "years"))
+})
+
+test_that("age_calc works correctly for months", {
+  expect_equal(age_calc(as.Date("2000-01-01"), as.Date("2020-01-01"),
+                        units = "months"), 240)
+})
+
+test_that("age_calc works correctly for months", {
+  expect_equal(round(age_calc(
+    as.Date("2000-07-07"), as.Date("2020-01-01"), units = "months"
+  )), 234)
+})
+
+test_that("age_calc works correctly for days", {
+  expect_equal(age_calc(as.Date("2000-01-01"), as.Date("2020-01-01"),
+                        units = "days"), 7305)
+  expect_length(age_calc(as.Date("2000-01-01"), as.Date("2020-01-01"),
+                         units = "days"), 1)
+})
+
+test_that("age_calc works correctly with leap years and precise set to TRUE", {
+  expect_equal(age_calc(
+    as.Date("2000-02-29"),
+    as.Date("2020-02-29"),
+    units = "years",
+    precise = TRUE
+  ),
+  20)
+})
+
+test_that("age_calc throws an error when enddate is before dob", {
+  expect_equal(age_calc(
+    as.Date("2000-01-01"),
+    as.Date("2014-05-11"),
+    precise = FALSE,
+    units = "years"
+  ),
+  14)
+})
+
+test_that("age_calc throws an error when wrong unit", {
+  expect_error(age_calc(as.Date("2020-01-01"), as.Date("2000-01-01"),
+                        units = "hours"))
+})
+
+test_that("age_calc throws an error when wrong format", {
+  expect_error(age_calc("2020-01-01", as.Date("2000-01-01"), units = "hours"))
+})
+
+test_that("age_calc throws an error when wrong format", {
+  expect_error(age_calc(as.Date("2020-01-01"), as.Date("2000-01-01"), 
+                        units = "years"))
+  expect_error(age_calc(as.Date("1982-01-01"), as.Date("2000-01-01"), 
+                        units = "seconds"))
+})

tests/testthat/test-contrast_text.R

@@ -0,0 +1,60 @@
+# Unit test for contrast_text()
+
+library(testthat)
+
+
+test_that("contrast_text() returns the correct text color", {
+  expect_equal(contrast_text("#FFFFFF"), "black")
+  expect_equal(contrast_text("#000000"), "white")
+  expect_equal(contrast_text("#FFFFFF", light_text="blue", dark_text="green"), 
+               "green")
+  expect_equal(contrast_text("#000000", light_text="blue", dark_text="green"), 
+               "blue")
+})
+
+################################################################################
+
+# library(devtools)
+# 
+# install_github("MangoTheCat/visualTest")
+# library(visualTest)
+# 
+# test_that("New test of color_plot()", {
+#   par(bg=NULL)
+#   colors <- colors()[34:53]
+#   
+#   # old <- getwd()
+#   # setwd("/Users/au301842/stRoke/tests/testthat")
+#   # setwd(old)
+#   
+#   png(filename = "data/test1.png")
+#   color_plot(colors,method="relative")
+#   dev.off()
+#   
+#   # getFingerprint("data/test1.png")
+#   
+#   expect_equal(getFingerprint("data/test1.png"), "AD07D27813E1D867")
+#   # isSimilar(tmp, "AD07D27813E1D867", threshold = 8)
+#   
+#   #############################
+#   
+#   # colors <- colors()[51:70]
+#   png(filename = "data/test2.png")
+#   color_plot(colors,labels = TRUE, borders = FALSE,cex_label = .5, ncol = 3, method="perceived_2")
+#   dev.off()
+#   
+#   # getFingerprint("data/test2.png")
+#   
+#   expect_equal(getFingerprint("data/test2.png"), "8B0B54D4E4AF2BB1")
+#   
+#   #############################
+#   
+#   png(filename = "data/test3.png")
+#   color_plot(colors,labels = FALSE, borders = TRUE, ncol = 6, method="perceived")
+#   dev.off()
+#   
+#   # getFingerprint("data/test3.png")
+#   
+#   expect_equal(getFingerprint("data/test3.png"), "B706F0F1C119CCF8")
+# })
+################################################################################

tests/testthat/test-ds2dd.R

@@ -0,0 +1,40 @@
+talos$id <- seq_len(nrow(talos))
+
+test_that("ds2dd gives desired output", {
+  expect_equal(ncol(ds2dd(talos, record.id = "id")), 18)
+  expect_s3_class(ds2dd(talos, record.id = "id"), "data.frame")
+  expect_s3_class(ds2dd(talos, record.id = 7), "data.frame")
+})
+
+
+test_that("ds2dd gives output with list of length two", {
+  expect_equal(length(ds2dd(
+    talos,
+    record.id = "id",
+    include.column.names = TRUE
+  )), 2)
+})
+
+
+test_that("ds2dd gives correct errors", {
+  expect_error(ds2dd(talos))
+  expect_error(ds2dd(talos, form.name = c("basis", "incl")))
+  expect_error(ds2dd(talos, field.type = c("text", "dropdown")))
+  expect_error(ds2dd(talos, field.label = c("Name", "Age")))
+})
+
+
+
+colnames(talos) <-
+  c("rtreat",
+    "mRS 1",
+    "mRS 6",
+    "hypertension",
+    "diabetes",
+    "civil",
+    "id")
+
+test_that("ds2dd correctly renames", {
+  expect_equal(ncol(ds2dd(talos, record.id = "id")), 18)
+  expect_s3_class(ds2dd(talos, record.id = "id"), "data.frame")
+})

tests/testthat/test-files_filter.R

@@ -0,0 +1,4 @@
+test_that("files_filter() correctly filters files", {
+  expect_type(files_filter(getwd(),"tests"),
+              "character")
+})

tests/testthat/test-generic_stroke.R

@@ -2,12 +2,12 @@ test_that("generic_stroke() runs!", {
   iris$ord <-
     factor(sample(1:3, size = nrow(iris), replace = TRUE), ordered = TRUE)
   result <-
-    suppressMessages(generic_stroke(
+    generic_stroke(
       df = iris,
       group = "Species",
       score = "ord",
       variables = colnames(iris)[1:3]
-    ))
+    )
   expect_equal(length(result), 3)
   expect_equal(class(result), "list")
   expect_true("tbl_summary" %in% class(result[[1]]))

tests/testthat/test-quantile_cut.R

@@ -0,0 +1,62 @@
+test_that("quatile_cut() works for detail.list==FALSE", {
+  result <- quantile_cut(iris$Sepal.Length, 3, detail.list = FALSE)
+  expect_equal(length(levels(result)), 3)
+  expect_s3_class(result, "factor")
+})
+
+################################################################################
+
+test_that("quatile_cut() works for inc.outs==TRUE", {
+  result <-
+    quantile_cut(iris$Sepal.Length,
+                 3,
+                 y = iris$Sepal.Length + 3,
+                 inc.outs = FALSE)
+  expect_true(any(is.na(result)))
+  
+  result <-
+    quantile_cut(iris$Sepal.Length,
+                 3,
+                 y = iris$Sepal.Length + 3,
+                 inc.outs = TRUE)
+  expect_false(any(is.na(result)))
+  expect_equal(length(levels(result)), 3)
+  expect_s3_class(result, "factor")
+})
+
+################################################################################
+
+test_that("quatile_cut() works for detail.list==TRUE", {
+  result <- quantile_cut(iris$Sepal.Length, 3, detail.list = TRUE)
+  expect_length(result, 2)
+  expect_type(result, "list")
+})
+
+################################################################################
+
+# Test created using remotes::install_github("JamesHWade/gpttools") 
+# unit test addin.
+test_that("quantile_cut works correctly", {
+  x <- runif(100)
+  groups <- 5
+  y <- runif(100)
+  expect_equal(
+    quantile_cut(x, groups, y, na.rm = TRUE),
+    cut(
+      x,
+      quantile(
+        y,
+        probs = seq(0, 1, 1 / groups),
+        na.rm = TRUE,
+        names = TRUE,
+        type = 7
+      ),
+      include.lowest = TRUE,
+      labels = NULL,
+      ordered_result = FALSE
+    )
+  )
+})
+
+################################################################################
+

tests/testthat/test-write_ical.R

@@ -0,0 +1,92 @@
+test_that("write_ical() returns a ical object", {
+ df <- data.frame(
+   date = c("2020-02-10", "2020-02-11", "2020-02-11"),
+   date.end = c("2020-02-13",NA,NA),
+   title = c("Conference", "Lunch", "Walk"),
+   start = c("12:00:00", NA, "08:00:00"),
+   time.end = c("13:00:00", NA, "17:30:00"),
+   note = c("Hi there","Remember to come", ""),
+   link = c("https://icalendar.org","https://agdamsbo.github.io/stRoke/", "")
+ )
+  
+ expect_s3_class(
+   write_ical(
+     df,
+     date.end = "date.end",
+     time.end = "time.end",
+     place.def = "Home",
+     descr = "note",
+     link = "link"
+   ),
+   "ical"
+ )
+})
+
+test_that("write_ical() returns a ical object", {
+  df <- data.frame(
+    date = c("2020-02-10", "2020-02-11", "2020-02-11"),
+    date.end = c("2020-02-13",NA,NA),
+    title = c("Conference", "Lunch", "Walk"),
+    start = c("12:00:00", NA, "08:00:00"),
+    time.end = c("13:00:00", NA, "17:30:00"),
+    place = c("Home", "Work", NA),
+    note = c("Hi there","Remember to come", ""),
+    link = c("https://icalendar.org","https://agdamsbo.github.io/stRoke/", "")
+  )
+  
+  expect_s3_class(
+    write_ical(
+      df,
+      date.end = "date.end",
+      time.end = "time.end",
+      place = "place",
+      descr = "note",
+      link = "link"
+    ),
+    "ical"
+  )
+})
+
+test_that("write_ical() returns error", {
+  df <- data.frame(
+    date = c("2020-02-10", "2020-02-11"),
+    title = c("Conference", "Lunch"),
+    start = c("12:00:00", NA),
+    end = c("13:00:00", NA),
+    note = c("Hi there","Remember to come"),
+    link = c("https://icalendar.org","https://agdamsbo.github.io/stRoke/")
+  )
+  expect_error(write_ical(df, date = "wrong"))
+  expect_error(write_ical(df, place = "wrong"))
+  expect_error(write_ical(df, title = "wrong"))
+  expect_error(write_ical(df, time.start = "wrong"))
+  expect_error(write_ical(df, time.end = "wrong"))
+})
+
+test_that("write_ical() returns error", {
+  df <- data.frame(
+    date = c("2020-02-10", "2020-02-11"),
+    date.end = c(NA,"2020-02-13"),
+    title = c("Conference", "Lunch"),
+    start = c("12:00:00", NA),
+    end = c("13:00:00", NA),
+    note = c("Hi there","Remember to come"),
+    link = c("https://icalendar.org","https://agdamsbo.github.io/stRoke/")
+  )
+  expect_error(write_ical(df,
+                          date.end = "date.end"))
+})
+
+test_that("write_ical() returns error", {
+  df <- data.frame(
+    date = c("2020-02-10", "2020-02-11"),
+    date.end = c("2020-02-13",NA),
+    title = c(NA, "Lunch"),
+    start = c("12:00:00", NA),
+    end = c("13:00:00", NA),
+    note = c("Hi there","Remember to come"),
+    link = c("https://icalendar.org","https://agdamsbo.github.io/stRoke/")
+  )
+  expect_error(write_ical(df,
+                          date.end = "date.end"))
+})

vignettes/ds2dd.Rmd

@@ -0,0 +1,87 @@
+---
+title: "ds2dd"
+date: "`r Sys.Date()`"
+output: rmarkdown::html_vignette
+vignette: >
+  %\VignetteIndexEntry{ds2dd}
+  %\VignetteEngine{knitr::rmarkdown}
+  %\VignetteEncoding{UTF-8}
+---
+
+```{r, include = FALSE}
+knitr::opts_chunk$set(
+  collapse = TRUE,
+  comment = "#>"
+)
+```
+
+```{r setup}
+library(stRoke)
+```
+
+# Easy data set to data base workflow
+
+This function can be used as a simple tool for creating at data base metadata file for REDCap (called a DataDictionary) based on a given data set file.
+
+## Step 1 - Load your data set
+
+Here we'll use the sample TALOS dataset included with the package.
+
+```{r}
+data("talos")
+ds <- talos
+# As the data set lacks an ID column, one is added
+ds$id <- seq_len(nrow(ds))
+```
+
+## Step 2 - Create the DataDictionary
+
+```{r}
+datadictionary <- ds2dd(ds,record.id = "id",include.column.names = TRUE)
+```
+
+Now additional specifications to the DataDictionary can be made manually, or it can be uploaded and modified manually in the graphical user interface on the web page.
+
+The function will transform column names to lower case and substitute spaces for underscores. The output is a list with the DataDictionary and a vector of new column names for the dataset to fit the meta data.
+
+## Step 3 - Meta data upload
+
+Now the DataDictionary can be exported as a spreadsheet and uploaded or it can be uploaded using the `REDCapR` package (only projects with "Development" status).
+
+Use one of the two approaches below:
+
+### Manual upload
+
+```{r eval=FALSE}
+write.csv(datadictionary$DataDictionary,"datadictionary.csv")
+```
+
+### Upload with `REDCapR`
+
+```{r eval=FALSE}
+REDCapR::redcap_metadata_write(
+  datadictionary$DataDictionary,
+  redcap_uri = keyring::key_get("DB_URI"),
+  token = keyring::key_get("DB_TOKEN")
+)
+```
+
+In the ["REDCap R Handbook"](https://agdamsbo.github.io/redcap-r-handbook/) more is written on interfacing with REDCap in R using the `library(keyring)`to store credentials in [chapter 1.1](https://agdamsbo.github.io/redcap-r-handbook/access.html#sec-getting-access).
+
+## Step 4 - Data upload
+
+The same two options are available for data upload as meta data upload: manual or through `REDCapR`.
+
+Only the latter is shown here.
+
+```{r eval=FALSE}
+# new column names are applied
+colnames(ds) <- datadictionary$`Column names`
+
+REDCapR::redcap_write(
+  ds,
+  redcap_uri = keyring::key_get("DB_URI"),
+  token = keyring::key_get("DB_TOKEN")
+)
+```
+

vignettes/toolbox.Rmd

@@ -25,13 +25,15 @@ My own toolbox in my small workshop is a mix of some old, worn, well proven tool
 
 I have tried to collect tools and functions from other packages that I use regularly in addition to functions that I have written myself to fill use cases, that I have not been able to find solutions to elsewhere.
 
+In documenting and testing the package, I have used [OpenAI's](https://platform.openai.com/overview) chatgpt with [gpttools](https://jameshwade.github.io/gpttools/). The chatgpt is an interesting tool, that is in no way perfect, but it helps with tedious tasks. Both `gpttools` and [`gptstudio`](https://michelnivard.github.io/gptstudio/) are interesting implementations in R and RStudio.
+
 ## CPR manipulations {#cpr-intro}
 
 Note that, if handled, CPR numbers (social security numbers) should be handled with care as they a considered highly sensitive data.
 
 The CPR number is structured as _DDMMYY-XXXX_, with the 1st _X_ designating decade of birth, the last _X_ designate binary gender (not biological sex) dependent on even/uneven as female/male, and the last for digits are used in a modulus calculation to verify the validity of the CPR number. Foreigners and unidentified persons are given temporary CPR numbers including letters.
 
-More information can be found on [cpr.dk](https://www.cpr.dk).
+More information can be found on [cpr.dk](https://cpr.dk).
 
 Note, that all CPR numbers used in examples are publicly known or non-organic.
 
@@ -46,7 +48,7 @@ trunc(age)
 
 ### cpr_check()
 
-Checks validity of CPR numbers according to the [modulus 11 rule](https://www.cpr.dk/cpr-systemet/opbygning-af-cpr-nummeret). Note that due to limitations in the possible available CPR numbers, this rule [does not apply to all CPR numbers after 2007](https://www.cpr.dk/cpr-systemet/personnumre-uden-kontrolciffer-modulus-11-kontrol).
+Checks validity of CPR numbers according to the [modulus 11 rule](https://cpr.dk/cpr-systemet/opbygning-af-cpr-nummeret). Note that due to limitations in the possible available CPR numbers, this rule [does not apply to all CPR numbers after 2007](https://cpr.dk/cpr-systemet/personnumre-uden-kontrolciffer-modulus-11-kontrol).
 
 ```{r cpr_check-example}
 cpr_check(
@@ -106,7 +108,7 @@ ci_plot(
 
 ### generic_stroke()
 
-For learning purposes. Uses anonymized data from the [TALOS trial](https://doi.org/10.1161/STROKEAHA.117.020067) to output a Table 1 (with `gtsummary::tbl_summary()`), plotting the so-called grotta-bars based on mRS scores (with `rankinPlot::grottaBar()`) and a ordinal logistic regression model plot (with `stRoke::ci_plot()`).
+For learning purposes. Uses annonymized data from the [TALOS trial](https://doi.org/10.1161/STROKEAHA.117.020067) to output a Table 1 (with `gtsummary::tbl_summary()`), plotting the so-called grotta-bars based on mRS scores (with `rankinPlot::grottaBar()`) and a ordinal logistic regression model plot (with `stRoke::ci_plot()`).
 
 ```{r generic_stroke-example}
 generic_stroke(stRoke::talos,