mirror of
https://github.com/agdamsbo/stRoke.git
synced 2025-04-19 04:43:55 +02:00
Compare commits
No commits in common. "main" and "v23.9.1" have entirely different histories.
@ -1,5 +1,3 @@
|
||||
^renv$
|
||||
^renv\.lock$
|
||||
^.*\.Rproj$
|
||||
^\.Rproj\.user$
|
||||
^\.github$
|
||||
|
95
.github/workflows/rhub.yaml
vendored
95
.github/workflows/rhub.yaml
vendored
@ -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 }}
|
23
DESCRIPTION
23
DESCRIPTION
@ -1,11 +1,11 @@
|
||||
Package: stRoke
|
||||
Title: Clinical Stroke Research
|
||||
Version: 24.10.1
|
||||
Version: 23.9.1
|
||||
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
|
||||
analysis in research and teaching.
|
||||
Description: 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.
|
||||
@ -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,
|
||||
pak,
|
||||
roxygen2,
|
||||
devtools
|
||||
testthat (>= 3.0.0)
|
||||
Language: en-US
|
||||
Config/testthat/edition: 3
|
||||
Imports:
|
||||
calendar,
|
||||
@ -41,10 +39,7 @@ Imports:
|
||||
rankinPlot,
|
||||
stats,
|
||||
tidyr,
|
||||
utils,
|
||||
tibble,
|
||||
tidyselect
|
||||
utils
|
||||
Depends:
|
||||
R (>= 2.10)
|
||||
VignetteBuilder: knitr
|
||||
Language: en-US
|
||||
|
@ -15,7 +15,6 @@ export(files_filter)
|
||||
export(generic_stroke)
|
||||
export(index_plot)
|
||||
export(label_select)
|
||||
export(mfi_domains)
|
||||
export(n_chunks)
|
||||
export(pase_calc)
|
||||
export(quantile_cut)
|
||||
|
15
NEWS.md
15
NEWS.md
@ -1,18 +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:
|
||||
|
@ -1,18 +1,16 @@
|
||||
#' MOVED Add padding to string
|
||||
#' 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){
|
||||
#' add_padding(sample(1:200,5))
|
||||
add_padding <- function(d,length=NULL,after=FALSE,pad="0"){
|
||||
if (!is.vector(d)) {
|
||||
stop("Please supply vector")
|
||||
}
|
||||
@ -33,11 +31,8 @@ add_padding <- function(d,length=NULL,after=FALSE,pad="0",lead=NULL,tail=NULL){
|
||||
paste(rep(pad,i),collapse="")}))
|
||||
|
||||
if (after) {
|
||||
out <- paste0(d,ps)
|
||||
paste0(d,ps)
|
||||
} else {
|
||||
out <- paste0(ps,d)
|
||||
paste0(ps,d)
|
||||
}
|
||||
|
||||
paste0(lead,out,tail)
|
||||
|
||||
}
|
||||
|
@ -1,4 +1,4 @@
|
||||
#' MOVED Split to chunks of size n
|
||||
#' Split to chunks of size n
|
||||
#'
|
||||
#' @param d data. Can be vector or data frame.
|
||||
#' @param n number of chunks
|
||||
|
@ -42,8 +42,8 @@ ci_plot <-
|
||||
title = NULL,
|
||||
method = "auto") {
|
||||
|
||||
if (!method %in% c("auto", "model")){
|
||||
stop("Method has to either 'auto' or 'model'")}
|
||||
if (!method %in% c("auto", "model"))
|
||||
stop("Method has to either 'auto' or 'model'")
|
||||
|
||||
if (method == "auto") {
|
||||
if (!is.factor(ds[, y]))
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
||||
|
@ -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"
|
||||
|
||||
|
80
R/mfi_calc.R
80
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()
|
||||
|
||||
}
|
@ -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,
|
||||
adjust_work = FALSE,
|
||||
consider.missing = c("Not available")) {
|
||||
pase_calc <- function(ds, adjust_work = FALSE) {
|
||||
|
||||
if (ncol(ds) != 21) {
|
||||
stop("supplied data set has to contain exactly 21 columns.
|
||||
Formatting should follow the stRoke::pase data set.")
|
||||
}
|
||||
if (ncol(ds) != 21) stop("supplied data set has to contain exactly 21 columns")
|
||||
|
||||
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) {
|
||||
x %in% consider.missing | is.na(x)
|
||||
apply(sapply(ds[, c(1, 3, 5, 7, 9, 11, 13:20)], function(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]") |>
|
||||
as.numeric() |>
|
||||
range(na.rm = TRUE) == c(0, 3))) {
|
||||
stop("Labelling of 02-06 should start with a number ranging 0-3")
|
||||
if (!all(range(suppressWarnings(as.numeric(substr(
|
||||
df[, 1], 1, 1
|
||||
))), na.rm = TRUE) == c(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
|
||||
n1 <- stRoke::str_extract(df[, 1],"^[0-3]") |> as.numeric()
|
||||
## Extracting the first string element in subentry
|
||||
n2 <- stRoke::str_extract(df[, 2],"^[1-4]") |> as.numeric()
|
||||
|
||||
score <- c()
|
||||
for (i in seq_along(n1)) {
|
||||
for (i in seq_len(nrow(df))) {
|
||||
# Setting categories from numbers
|
||||
n1 <- suppressWarnings(as.numeric(substr(df[, 1][i], 1, 1)))
|
||||
|
||||
ind1 <- match(n1[i],seq_along(pase_weights))
|
||||
|
||||
if (is.na(ind1)){
|
||||
score[i] <- n1[i]
|
||||
# Using if statement to calculate row wise
|
||||
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]
|
||||
|
||||
} else if (n1 %in% 0) {
|
||||
score[i] <- 0
|
||||
} 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),
|
||||
pase_score_missings = missings,
|
||||
pase_score_incompletes = incompletes
|
||||
score_sum = rowSums(pase_score, na.rm = TRUE),
|
||||
score_missings = missings,
|
||||
score_incompletes = incompletes
|
||||
)
|
||||
}
|
||||
|
@ -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().
|
||||
#'
|
||||
|
@ -1,7 +1,5 @@
|
||||
#' 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
|
||||
|
@ -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()`.
|
||||
|
@ -1,6 +1,23 @@
|
||||
── R CMD check results ───────────────────────────────────────────────────────────────────────── stRoke 24.10.1 ────
|
||||
Duration: 28.4s
|
||||
> results$cran_summary()
|
||||
For a CRAN submission we recommend that you fix all NOTEs, WARNINGs and ERRORs.
|
||||
## Test environments
|
||||
- R-hub windows-x86_64-devel (r-devel)
|
||||
- R-hub ubuntu-gcc-release (r-release)
|
||||
- R-hub fedora-clang-devel (r-devel)
|
||||
|
||||
0 errors ✔ | 0 warnings ✔ | 0 notes ✔
|
||||
## R CMD check results
|
||||
❯ On windows-x86_64-devel (r-devel)
|
||||
checking for non-standard things in the check directory ... NOTE
|
||||
Found the following files/directories:
|
||||
''NULL''
|
||||
|
||||
R CMD check succeeded
|
||||
❯ On windows-x86_64-devel (r-devel)
|
||||
checking for detritus in the temp directory ... NOTE
|
||||
Found the following files/directories:
|
||||
'lastMiKTeXException'
|
||||
|
||||
❯ On ubuntu-gcc-release (r-release), fedora-clang-devel (r-devel)
|
||||
checking HTML version of manual ... NOTE
|
||||
Skipping checking HTML validation: no command 'tidy' found
|
||||
|
||||
0 errors ✔ | 0 warnings ✔ | 3 notes ✖
|
@ -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")
|
||||
|
BIN
data/cprs.rda
BIN
data/cprs.rda
Binary file not shown.
@ -1,21 +1,24 @@
|
||||
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 +30,11 @@ XXXX
|
||||
Zou
|
||||
agdamsbo
|
||||
al
|
||||
anonymized
|
||||
annonymized
|
||||
bstfun
|
||||
calc
|
||||
characterstrings
|
||||
chatgpt
|
||||
christophergandrud
|
||||
ci
|
||||
codecov
|
||||
@ -41,7 +45,6 @@ cprs
|
||||
daDoctoR
|
||||
ddmmyy
|
||||
ddmmyyxxxx
|
||||
dev
|
||||
difftime
|
||||
dk
|
||||
doi
|
||||
@ -78,9 +81,7 @@ rgb
|
||||
sapply
|
||||
stackoverflow
|
||||
strsplit
|
||||
subscores
|
||||
teppo
|
||||
tibble
|
||||
vapply
|
||||
vec
|
||||
winP
|
||||
|
@ -2,16 +2,9 @@
|
||||
% Please edit documentation in R/add_padding.R
|
||||
\name{add_padding}
|
||||
\alias{add_padding}
|
||||
\title{MOVED Add padding to string}
|
||||
\title{Add padding to string}
|
||||
\usage{
|
||||
add_padding(
|
||||
d,
|
||||
length = NULL,
|
||||
after = FALSE,
|
||||
pad = "0",
|
||||
lead = NULL,
|
||||
tail = NULL
|
||||
)
|
||||
add_padding(d, length = NULL, after = FALSE, pad = "0")
|
||||
}
|
||||
\arguments{
|
||||
\item{d}{vector of strings or numbers}
|
||||
@ -21,17 +14,13 @@ add_padding(
|
||||
\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
|
||||
Add padding to string
|
||||
}
|
||||
\examples{
|
||||
add_padding(sample(1:200,5),tail="AA",lead=c(2,3,"e"))
|
||||
add_padding(sample(1:200,5))
|
||||
}
|
||||
|
@ -2,7 +2,7 @@
|
||||
% 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}
|
||||
\title{Split to chunks of size n}
|
||||
\usage{
|
||||
chunks_of_n(d, n, label = NULL, even = FALSE, pattern = NULL)
|
||||
}
|
||||
@ -22,7 +22,7 @@ frame, will assume first column is name.}
|
||||
List of length n
|
||||
}
|
||||
\description{
|
||||
MOVED Split to chunks of size n
|
||||
Split to chunks of size n
|
||||
}
|
||||
\examples{
|
||||
tail(chunks_of_n(seq_len(100),7),3)
|
||||
|
@ -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,
|
||||
|
@ -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)
|
||||
}
|
||||
|
@ -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}
|
||||
|
@ -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()
|
||||
}
|
@ -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)
|
||||
}
|
@ -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{consider.missing}{character vector of values considered missing.
|
||||
\item{adjust_work}{flag to set whether to include 10b type 1.
|
||||
Default is TRUE.}
|
||||
}
|
||||
\value{
|
||||
@ -43,6 +41,5 @@ set \code{TRUE}.
|
||||
}
|
||||
\examples{
|
||||
summary(pase_calc(stRoke::pase)[,13])
|
||||
str(pase_calc(stRoke::pase))
|
||||
|
||||
}
|
||||
|
@ -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,
|
||||
|
@ -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:
|
||||
|
@ -15,9 +15,6 @@ str_extract(d, pattern)
|
||||
vector of character strings
|
||||
}
|
||||
\description{
|
||||
DEPRECATION: moved to \code{agdamsbo/project.aid}
|
||||
}
|
||||
\details{
|
||||
Use base::strsplit to
|
||||
}
|
||||
\examples{
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
3
tests/spelling.R
Normal file
3
tests/spelling.R
Normal file
@ -0,0 +1,3 @@
|
||||
if(requireNamespace('spelling', quietly = TRUE))
|
||||
spelling::spell_check_test(vignettes = TRUE, error = FALSE,
|
||||
skip_on_cran = TRUE)
|
BIN
tests/testthat/Rplots.pdf
Normal file
BIN
tests/testthat/Rplots.pdf
Normal file
Binary file not shown.
BIN
tests/testthat/data/test1.png
Normal file
BIN
tests/testthat/data/test1.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 32 KiB |
BIN
tests/testthat/data/test2.png
Normal file
BIN
tests/testthat/data/test2.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 17 KiB |
BIN
tests/testthat/data/test3.png
Normal file
BIN
tests/testthat/data/test3.png
Normal file
Binary file not shown.
After Width: | Height: | Size: 8.4 KiB |
17
tests/testthat/test-add_padding.R
Normal file
17
tests/testthat/test-add_padding.R
Normal file
@ -0,0 +1,17 @@
|
||||
test_that("chunks_of_n returns correct", {
|
||||
expect_length(add_padding(sample(1:200,5)),5)
|
||||
|
||||
expect_equal(nchar(add_padding(sample(1:200,5),5)), rep(5,5))
|
||||
|
||||
expect_equal(nchar(add_padding(
|
||||
sample(1:200, 5), length = 5, after = TRUE
|
||||
)), rep(5, 5))
|
||||
|
||||
|
||||
## Errors
|
||||
expect_error(add_padding(matrix(sample(1:200,5)),5))
|
||||
|
||||
expect_error(add_padding(matrix(sample(1:200,5)),5,pad = "123"))
|
||||
|
||||
|
||||
})
|
72
tests/testthat/test-age_calc.R
Normal file
72
tests/testthat/test-age_calc.R
Normal file
@ -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"))
|
||||
})
|
69
tests/testthat/test-chunks.R
Normal file
69
tests/testthat/test-chunks.R
Normal file
@ -0,0 +1,69 @@
|
||||
library(testthat)
|
||||
test_that("chunks_of_n returns correct", {
|
||||
expect_length(chunks_of_n(seq_len(100), 7),15)
|
||||
|
||||
expect_equal(lengths(chunks_of_n(seq_len(30), 7, even = TRUE),
|
||||
use.names = FALSE), c(6, 6, 6, 6, 6))
|
||||
|
||||
# This is the example from the function, but I believe it fails in GitHub testing
|
||||
ds <- data.frame(nm = paste0("Sub",
|
||||
add_padding(rownames(stRoke::talos))),
|
||||
stRoke::talos)
|
||||
|
||||
# ds <- data.frame(nm = paste0("Sub",rownames(stRoke::talos)),
|
||||
# stRoke::talos)
|
||||
|
||||
expect_equal(head(names(chunks_of_n(ds, 7,
|
||||
pattern = "Sub[0-9]{3}", label = "grp")),
|
||||
1),"grp-Sub038-Sub011")
|
||||
|
||||
expect_equal(
|
||||
ds[order(ds$nm),] |>
|
||||
chunks_of_n(7, pattern = "Sub([0-9]+)", label = "grp") |>
|
||||
head(1) |> names(),
|
||||
"grp-Sub001-Sub020"
|
||||
)
|
||||
|
||||
expect_equal(
|
||||
ds[order(ds$nm),] |>
|
||||
chunks_of_n(7, pattern = "Sub[0-9]{3}", label = "grp") |>
|
||||
head(1) |> names(),
|
||||
"grp-Sub001-Sub020"
|
||||
)
|
||||
|
||||
## Errors
|
||||
expect_error(chunks_of_n(list(ds), 7, pattern = "Sub[0-9]{3}", label = "grp"))
|
||||
|
||||
|
||||
})
|
||||
|
||||
test_that("n_chunks returns correct", {
|
||||
expect_length(n_chunks(seq_len(100), 7),7)
|
||||
|
||||
expect_equal(lengths(n_chunks(seq_len(30), 7, even = TRUE),
|
||||
use.names = FALSE), rep(5,6))
|
||||
|
||||
## This is the example from the function, but I believe it fails in GitHub testing
|
||||
ds <- data.frame(nm = paste0("Sub",
|
||||
add_padding(rownames(stRoke::talos))),
|
||||
stRoke::talos)
|
||||
|
||||
# ds <- data.frame(nm = paste0("Sub",rownames(stRoke::talos)),
|
||||
# stRoke::talos)
|
||||
|
||||
expect_equal(head(names(n_chunks(ds, 7,
|
||||
pattern = "Sub([0-9]+)", label = "grp")),
|
||||
1),"grp-Sub038-Sub603")
|
||||
|
||||
expect_equal(
|
||||
ds[order(ds$nm), ] |>
|
||||
n_chunks(7, pattern = "Sub([0-9]+)", label = "grp") |>
|
||||
head(1) |> names(),
|
||||
"grp-Sub001-Sub072"
|
||||
)
|
||||
|
||||
## Errors
|
||||
expect_error(n_chunks(list(ds), 7, pattern = "Sub([0-9]+)", label = "grp"))
|
||||
|
||||
|
||||
})
|
60
tests/testthat/test-contrast_text.R
Normal file
60
tests/testthat/test-contrast_text.R
Normal file
@ -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")
|
||||
# })
|
||||
################################################################################
|
40
tests/testthat/test-ds2dd.R
Normal file
40
tests/testthat/test-ds2dd.R
Normal file
@ -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")
|
||||
})
|
4
tests/testthat/test-files_filter.R
Normal file
4
tests/testthat/test-files_filter.R
Normal file
@ -0,0 +1,4 @@
|
||||
test_that("files_filter() correctly filters files", {
|
||||
expect_type(files_filter(getwd(),"tests"),
|
||||
"character")
|
||||
})
|
@ -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]]))
|
||||
|
62
tests/testthat/test-quantile_cut.R
Normal file
62
tests/testthat/test-quantile_cut.R
Normal file
@ -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
|
||||
)
|
||||
)
|
||||
})
|
||||
|
||||
################################################################################
|
||||
|
15
tests/testthat/test-str_extract.R
Normal file
15
tests/testthat/test-str_extract.R
Normal file
@ -0,0 +1,15 @@
|
||||
# library(testthat)
|
||||
test_that("str_extract returns correct", {
|
||||
ls <- do.call(c, lapply(sample(4:8, 20, T), function(i) {
|
||||
paste(sample(letters, i, T), collapse = "")
|
||||
}))
|
||||
|
||||
ds <- do.call(c, lapply(1:20, function(i) {
|
||||
paste(sample(ls, 1), i, sample(ls, 1), "23", sep = "_")
|
||||
}))
|
||||
|
||||
expect_equal(nchar(str_extract(ds, "([0-9]+)")),c(rep(1,9),rep(2,11)))
|
||||
|
||||
expect_error(str_extract(data.frame(ds), "([0-9]+)"))
|
||||
|
||||
})
|
92
tests/testthat/test-write_ical.R
Normal file
92
tests/testthat/test-write_ical.R
Normal file
@ -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"))
|
||||
})
|
Binary file not shown.
87
vignettes/ds2dd.Rmd
Normal file
87
vignettes/ds2dd.Rmd
Normal file
@ -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")
|
||||
)
|
||||
```
|
||||
|
@ -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,
|
||||
|
Loading…
x
Reference in New Issue
Block a user