cpr_tools

This commit is contained in:
AG Damsbo 2022-09-22 14:20:46 +02:00
parent e415de2381
commit df96859269
17 changed files with 386 additions and 0 deletions

2
.Rbuildignore Normal file
View File

@ -0,0 +1,2 @@
^.*\.Rproj$
^\.Rproj\.user$

16
DESCRIPTION Normal file
View File

@ -0,0 +1,16 @@
Package: stRoke
Title: Providing tools for work in clinical stroke research.
Version: 0.0.0.9000
Authors@R:
person("Andreas Gammelgaard", "Damsbo", , "agdamsbo@clin.au.dk", role = c("aut", "cre"),
comment = c(ORCID = "0000-0002-7559-1154"))
Description: For a start this package migrates functions from the agdamsbo/daDoctoR-package.
License: GPL-3
Encoding: UTF-8
Roxygen: list(markdown = TRUE)
RoxygenNote: 7.2.1
Suggests:
spelling,
testthat (>= 3.0.0)
Language: en-US
Config/testthat/edition: 3

5
NAMESPACE Normal file
View File

@ -0,0 +1,5 @@
# Generated by roxygen2: do not edit by hand
export(age_calc)
export(cpr_check)
export(cpr_dob)

94
R/age_calc.R Normal file
View File

@ -0,0 +1,94 @@
#' Calculating age from date of birth
#'
#' For age calculations. Vectorised.
#' @param dob Date of birth. Data format follows standard POSIX layout. Format is yyyy-mm-dd.
#' @param enddate Date to calculate age at. Format is yyyy-mm-dd.
#' @param units Default is "years". Can be changed to "days".
#' @param precise Default is TRUE. Flag set whether to include calculations of spring years. Only of matter if using units = "days".
#' @keywords age
#'
#' @return Vector of age
#' @export
#'
#' @examples
#' # Kim Larsen (cpr is known from album)
#' dob<-daDoctoR::dob_extract_cpr("231045-0637")
#' date<-as.Date("2018-09-30")
#' trunc(age_calc(dob,date))
age_calc<-function (dob, enddate = Sys.Date(), units = "years", precise = TRUE)
## Build upon the work of Jason P. Becker, as part of the eeptools
## Alternative is to just use lubridate::time_length
{
if (!inherits(dob, "Date") | !inherits(enddate, "Date")) {
stop("Both dob and enddate must be Date class objects")
}
if (length(dob)==1 && enddate < dob) {
stop("End date must be a date after date of birth")
}
if (length(dob)>1 && any(enddate < dob)) {
stop("End date must be a date after date of birth")
}
start <- as.POSIXlt(dob)
end <- as.POSIXlt(enddate)
if (precise) {
start_is_leap <- ifelse(start$year%%400 == 0, TRUE, ifelse(start$year%%100 ==
0, FALSE, ifelse(start$year%%4 == 0, TRUE, FALSE)))
end_is_leap <- ifelse(end$year%%400 == 0, TRUE, ifelse(end$year%%100 ==
0, FALSE, ifelse(end$year%%4 == 0, TRUE, FALSE)))
}
if (units == "days") {
result <- difftime(end, start, units = "days")
}
else if (units == "months") {
months <- sapply(mapply(seq, as.POSIXct(start), as.POSIXct(end),
by = "months", SIMPLIFY = FALSE), length) - 1
if (precise) {
month_length_end <- ifelse(end$mon == 1 & end_is_leap,
29, ifelse(end$mon == 1, 28, ifelse(end$mon %in%
c(3, 5, 8, 10), 30, 31)))
month_length_prior <- ifelse((end$mon - 1) == 1 &
start_is_leap, 29, ifelse((end$mon - 1) == 1,
28, ifelse((end$mon - 1) %in% c(3, 5, 8, 10),
30, 31)))
month_frac <- ifelse(end$mday > start$mday, (end$mday -
start$mday)/month_length_end, ifelse(end$mday <
start$mday, (month_length_prior - start$mday)/month_length_prior +
end$mday/month_length_end, 0))
result <- months + month_frac
}
else {
result <- months
}
}
else if (units == "years") {
years <- sapply(mapply(seq, as.POSIXct(start), as.POSIXct(end),
by = "years", SIMPLIFY = FALSE), length) - 1
if (precise) {
start_length <- ifelse(start_is_leap, 366, 365)
end_length <- ifelse(end_is_leap, 366, 365)
start_day <- ifelse(start_is_leap & start$yday >=
60, start$yday - 1, start$yday)
end_day <- ifelse(end_is_leap & end$yday >= 60, end$yday -
1, end$yday)
year_frac <- ifelse(start_day < end_day, (end_day -
start_day)/end_length, ifelse(start_day > end_day,
(start_length - start_day)/start_length + end_day/end_length,
0))
result <- years + year_frac
}
else {
result <- years
}
}
else {
stop("Unrecognized units. Please choose years, months, or days.")
}
return(result)
}

111
R/cpr_tools.R Normal file
View File

@ -0,0 +1,111 @@
#' CPR check
#'
#' Checking validity of cpr number. Vectorised.
#' @param cpr cpr-numbers as ddmmyy[-.]xxxx or ddmmyyxxxx. Also mixed formatting. Vector or data frame column.
#' @keywords cpr
#'
#' @return Logical vector
#' @export
#'
#' @examples
#' fsd<-c("2310450637", "010115-4000", "0101896000","010189-3000","300450-1030","010150-4021")
#' cpr_check(fsd)
#' all(cpr_check(fsd))
cpr_check<-function(cpr){
# Check validity of CPR number, format ddmmyy-xxxx
# Build upon data from this document: https://cpr.dk/media/167692/personnummeret%20i%20cpr.pdf
v <- c()
for (i in seq_along(cpr)){
x <- cpr[i]
if (!substr(x,7,7)%in%c("-",".")){ # Added check to take p8 if ddmmyy[-.]xxxx,
x<-paste(substr(x,1,6),substr(x,7,10),collapse="-")
}
p1<-as.integer(substr(x,1,1))
p2<-as.integer(substr(x,2,2))
p3<-as.integer(substr(x,3,3))
p4<-as.integer(substr(x,4,4))
p5<-as.integer(substr(x,5,5))
p6<-as.integer(substr(x,6,6))
p7<-as.integer(substr(x,8,8))
p8<-as.integer(substr(x,9,9))
p9<-as.integer(substr(x,10,10))
p10<-as.integer(substr(x,11,11))
v[i] <- ifelse((p1*4+p2*3+p3*2+p4*7+p5*6+p6*5+p7*4+p8*3+p9*2+p10) %% 11 == 0,TRUE,FALSE)
}
return(v)
}
#' Extracting date of birth from CPR
#'
#' For easy calculation.
#' @param cpr cpr-numbers as ddmmyy[-.]xxxx or ddmmyyxxxx. Also mixed formatting. Vector or data frame column.
#' @keywords cpr
#'
#' @return vector of Date elements. Format yyyy-mm-dd
#' @export
#'
#' @examples
#' cpr_dob("231045-0637")
#' fsd<-c("010190-2000", "010115-4000", "0101896000","010189-3000","300450-1030","010150-4021")
#' cpr_dob(fsd)
cpr_dob<-function(cpr){
## Input as cpr-numbers in format ddmmyy-xxxx
## Build upon data from this document: https://cpr.dk/media/167692/personnummeret%20i%20cpr.pdf
dobs<-c()
a00<-as.numeric(c(0:99))
a36<-as.numeric(c(0:36))
a57<-as.numeric(c(0:57))
b00<-as.numeric(c(0,1,2,3))
b36<-as.numeric(c(4,9))
b57<-as.numeric(c(5,6,7,8))
for (i in seq_along(cpr)){
x <- cpr[i]
p56<-as.numeric(substr(x,5,6))
if (substr(x,7,7)%in%c("-",".")){
p8<-as.numeric(substr(x,8,8)) # Added check to take p8 if ddmmyy[-.]xxxx,
} else {p8<-as.numeric(substr(x,7,7))} # or p7 if ddmmyyxxxx
birth<-as.Date(substr(x,1,6),format="%d%m%y")
if (((p56%in%a00)&&(p8%in%b00)))
{
dob<-as.Date(format(birth, format="19%y%m%d"), format="%Y%m%d")
}
else if (((p56%in%a36)&&(p8%in%b36)))
{
dob<-as.Date(format(birth, format="20%y%m%d"), format="%Y%m%d")
}
else if ((!(p56%in%a36)&&(p8%in%b36)))
{
dob<-as.Date(format(birth, format="19%y%m%d"), format="%Y%m%d")
}
else if (((p56%in%a57)&&(p8%in%b57)))
{
dob<-as.Date(format(birth, format="20%y%m%d"), format="%Y%m%d")
}
else if ((!(p56%in%a57)&&(p8%in%b57)))
{
dob<-as.Date(format(birth, format="18%y%m%d"), format="%Y%m%d")
}
else {print("Input contains data in wrong format") # test if position 5,6 or 8 contains letters as is the case for temporary cpr-numbers
}
dobs[i]<-dob
}
as.Date(dobs, origin = "1970-01-01")
}

6
R/stRoke-package.R Normal file
View File

@ -0,0 +1,6 @@
#' @keywords internal
"_PACKAGE"
## usethis namespace: start
## usethis namespace: end
NULL

11
inst/WORDLIST Normal file
View File

@ -0,0 +1,11 @@
Andreas
Gammelgaard
ORCID
Vectorised
agdamsbo
cpr
daDoctoR
ddmmyy
ddmmyyxxxx
xxxx
yyyy

30
man/age_calc.Rd Normal file
View File

@ -0,0 +1,30 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/age_calc.R
\name{age_calc}
\alias{age_calc}
\title{Calculating age from date of birth}
\usage{
age_calc(dob, enddate = Sys.Date(), units = "years", precise = TRUE)
}
\arguments{
\item{dob}{Date of birth. Data format follows standard POSIX layout. Format is yyyy-mm-dd.}
\item{enddate}{Date to calculate age at. Format is yyyy-mm-dd.}
\item{units}{Default is "years". Can be changed to "days".}
\item{precise}{Default is TRUE. Flag set whether to include calculations of spring years. Only of matter if using units = "days".}
}
\value{
Vector of age
}
\description{
For age calculations. Vectorised.
}
\examples{
# Kim Larsen (cpr is known from album)
dob<-daDoctoR::dob_extract_cpr("231045-0637")
date<-as.Date("2018-09-30")
trunc(age_calc(dob,date))
}
\keyword{age}

23
man/cpr_check.Rd Normal file
View File

@ -0,0 +1,23 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/cpr_tools.R
\name{cpr_check}
\alias{cpr_check}
\title{CPR check}
\usage{
cpr_check(cpr)
}
\arguments{
\item{cpr}{cpr-numbers as ddmmyy\link{-.}xxxx or ddmmyyxxxx. Also mixed formatting. Vector or data frame column.}
}
\value{
Logical vector
}
\description{
Checking validity of cpr number. Vectorised.
}
\examples{
fsd<-c("2310450637", "010115-4000", "0101896000","010189-3000","300450-1030","010150-4021")
cpr_check(fsd)
all(cpr_check(fsd))
}
\keyword{cpr}

23
man/cpr_dob.Rd Normal file
View File

@ -0,0 +1,23 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/cpr_tools.R
\name{cpr_dob}
\alias{cpr_dob}
\title{Extracting date of birth from CPR}
\usage{
cpr_dob(cpr)
}
\arguments{
\item{cpr}{cpr-numbers as ddmmyy\link{-.}xxxx or ddmmyyxxxx. Also mixed formatting. Vector or data frame column.}
}
\value{
vector of Date elements. Format yyyy-mm-dd
}
\description{
For easy calculation.
}
\examples{
cpr_dob("231045-0637")
fsd<-c("010190-2000", "010115-4000", "0101896000","010189-3000","300450-1030","010150-4021")
cpr_dob(fsd)
}
\keyword{cpr}

15
man/stRoke-package.Rd Normal file
View File

@ -0,0 +1,15 @@
% Generated by roxygen2: do not edit by hand
% Please edit documentation in R/stRoke-package.R
\docType{package}
\name{stRoke-package}
\alias{stRoke}
\alias{stRoke-package}
\title{stRoke: Providing tools for work in clinical stroke research.}
\description{
For a start this package migrates functions from the agdamsbo/daDoctoR-package.
}
\author{
\strong{Maintainer}: Andreas Gammelgaard Damsbo \email{agdamsbo@clin.au.dk} (\href{https://orcid.org/0000-0002-7559-1154}{ORCID})
}
\keyword{internal}

9
setup help.R Normal file
View File

@ -0,0 +1,9 @@
usethis::use_description(list(License = "GPL-3"))
usethis::use_namespace()
dir.create("R")
usethis::use_package_doc()
usethis::use_roxygen_md()
usethis::use_package()
spelling::spell_check_setup()

View File

@ -11,3 +11,8 @@ Encoding: UTF-8
RnwWeave: Sweave
LaTeX: pdfLaTeX
BuildType: Package
PackageUseDevtools: Yes
PackageInstallArgs: --no-multiarch --with-keep.source
PackageRoxygenize: rd,collate,namespace

3
tests/spelling.R Normal file
View File

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

12
tests/testthat.R Normal file
View File

@ -0,0 +1,12 @@
# This file is part of the standard setup for testthat.
# It is recommended that you do not modify it.
#
# Where should you do additional test configuration?
# Learn more about the roles of various files in:
# * https://r-pkgs.org/tests.html
# * https://testthat.r-lib.org/reference/test_package.html#special-files
library(testthat)
library(stRoke)
test_check("stRoke")

View File

@ -0,0 +1,4 @@
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)
})

View File

@ -0,0 +1,17 @@
test_that("cpr_check() works for vectors, giving logicals", {
result <- cpr_check(c("2310450637", "010115-4000", "0101896000","010189-3000","300450-1030","010150-4021"))
expect_equal(any(result), TRUE)
expect_type(result, "logical")
expect_equal(result[2], FALSE)
})
################################################################################
test_that("cpr_dob() works for vectors, giving logicals", {
result <- cpr_dob(c("2310450637", "010115-4000", "0101896000","010189-3000","300450-1030","010150-4021"))
expect_type(result, "double")
expect_s3_class(result, "Date")
expect_length(result, 6)
})
################################################################################