andreas/daDoctoR
1
0
Fork 0
mirror of https://github.com/agdamsbo/daDoctoR.git synced 2024-11-22 03:40:23 +01:00
Code Issues Projects Releases Wiki Activity

examples

Browse Source
This commit is contained in:
agdamsbo 2018-10-04 17:04:15 +02:00
parent 8be45013f1
commit cc48f5cac4
8 changed files with 50 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
R/age_calc_function.R
View File

@ -6,9 +6,12 @@
#' @keywords age
#' @export
#' @examples
#' age_calc()
#' ##Kim Larsen
#' dob<-dob_extract_cpr("231045-0637")
#' date<-as.Date("2018-09-29")
#' trunc(age_calc(dob,date))
age_calc<-function (dob, enddate = Sys.Date(), units = "years", precise = TRUE)
age_calc<-function (dob, enddate = Sys.Date(), units = "years", precise = TRUE)
## Build upon the work of Jason P. Becker, as part of tihe eeptools
{
if (!inherits(dob, "Date") | !inherits(enddate, "Date")) {
@ -20,28 +23,28 @@ age_calc<-function (dob, enddate = Sys.Date(), units = "years", precise = TRUE)
start <- as.POSIXlt(dob)
end <- as.POSIXlt(enddate)
if (precise) {
start_is_leap <- ifelse(start$year%%400 == 0, TRUE, ifelse(start$year%%100 ==
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 ==
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),
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%
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),
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 +
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
}
@ -50,18 +53,18 @@ age_calc<-function (dob, enddate = Sys.Date(), units = "years", precise = TRUE)
}
}
else if (units == "years") {
years <- sapply(mapply(seq, as.POSIXct(start), as.POSIXct(end),
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 >=
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 -
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,
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
}
@ -73,4 +76,4 @@ age_calc<-function (dob, enddate = Sys.Date(), units = "years", precise = TRUE)
stop("Unrecognized units. Please choose years, months, or days.")
}
return(result)
}
}

8
R/cpr_check_function.R
View File

@ -5,11 +5,11 @@
#' @keywords cpr
#' @export
#' @examples
#' cpr_check()
#' cpr_check("231045-0637")
cpr_check<-function(x){
#Check validity of CPR number, format ddmmyy-xxxx
p1<-as.integer(substr(x,1,1))
p2<-as.integer(substr(x,2,2))
p3<-as.integer(substr(x,3,3))
@ -20,7 +20,7 @@ cpr_check<-function(x){
p8<-as.integer(substr(x,9,9))
p9<-as.integer(substr(x,10,10))
p10<-as.integer(substr(x,11,11))
result<-ifelse((p1*4+p2*3+p3*2+p4*7+p5*6+p6*5+p7*4+p8*3+p9*2+p10) %% 11 == 0,"valid","invalid")
return(result)
}
}

8
R/cpr_sex_function.R
View File

@ -5,12 +5,12 @@
#' @keywords cpr
#' @export
#' @examples
#' cpr_sex()
#' cpr_sex("231045-0637")
cpr_sex<-function(x){
cpr_sex<-function(x){
##Input as vector of DK cpr numbers, format "ddmmyy-xxxx", returns sex according to cpr
last<-as.integer(substr(x, start = 11, stop = 11))
sex<-ifelse(last %% 2 == 0, "female", "male")
return(sex)
}
}

24
R/dob_extract_cpr_function.R
View File

@ -5,7 +5,7 @@
#' @keywords cpr
#' @export
#' @examples
#' dob_extract_cpr()
#' dob_extract_cpr("231045-0637")
dob_extract_cpr<-function(cpr)
@ -16,47 +16,47 @@ dob_extract_cpr<-function(cpr)
if (any(substr(cpr,7,7)%in%c(0:9))){stop("Input format should be ddmmyy-xxxx")} # test if input is ddmmyyxxxx
else {
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 (x in cpr)
{
p56<-as.numeric(substr(x,5,6))
p8<-as.numeric(substr(x,8,8))
birth<-as.Date(substr(x,1,6),format="%d%m%y")
if (((p56%in%a00)&&(p8%in%b00)))
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)))
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)))
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)))
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)))
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<-append(dobs,dob)
}
return(dobs)
}
}

5
man/age_calc.Rd
View File

@ -15,6 +15,9 @@ age_calc(dob, enddate = Sys.Date(), units = "years", precise = TRUE)
For age calculations.
}
\examples{
age_calc()
##Kim Larsen
dob<-dob_extract_cpr("231045-0637")
date<-as.Date("2018-09-29")
trunc(age_calc(dob,date))
}
\keyword{age}

2
man/cpr_check.Rd
View File

@ -13,6 +13,6 @@ cpr_check(x)
Checking validity of cpr number
}
\examples{
cpr_check()
cpr_check("231045-0637")
}
\keyword{cpr}

2
man/cpr_sex.Rd
View File

@ -13,6 +13,6 @@ cpr_sex(x)
Format "ddmmyy-xxxx"
}
\examples{
cpr_sex()
cpr_sex("231045-0637")
}
\keyword{cpr}

2
man/dob_extract_cpr.Rd
View File

@ -13,6 +13,6 @@ dob_extract_cpr(cpr)
For easy calculation.
}
\examples{
dob_extract_cpr()
dob_extract_cpr("231045-0637")
}
\keyword{cpr}