cpr_tools

.Rbuildignore

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

DESCRIPTION

@@ -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

NAMESPACE

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

R/age_calc.R

@@ -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)
+}

R/cpr_tools.R

@@ -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")
+  
+}

R/stRoke-package.R

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

inst/WORDLIST

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

man/age_calc.Rd

@@ -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}

man/cpr_check.Rd

@@ -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}

man/cpr_dob.Rd

@@ -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}

man/stRoke-package.Rd

@@ -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}

setup help.R

@@ -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()

stRoke.Rproj

@@ -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

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.R

@@ -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")

tests/testthat/test-age_calc.R

@@ -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)
+})

tests/testthat/test-cpr_tools.R

@@ -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)
+})
+
+################################################################################