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 #' @keywords age
#' @export #' @export
#' @examples #' @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 ## Build upon the work of Jason P. Becker, as part of tihe eeptools
{ {
if (!inherits(dob, "Date") | !inherits(enddate, "Date")) { 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) start <- as.POSIXlt(dob)
end <- as.POSIXlt(enddate) end <- as.POSIXlt(enddate)
if (precise) { 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))) 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))) 0, FALSE, ifelse(end$year%%4 == 0, TRUE, FALSE)))
} }
if (units == "days") { if (units == "days") {
result <- difftime(end, start, units = "days") result <- difftime(end, start, units = "days")
} }
else if (units == "months") { 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 by = "months", SIMPLIFY = FALSE), length) - 1
if (precise) { if (precise) {
month_length_end <- ifelse(end$mon == 1 & end_is_leap, month_length_end <- ifelse(end$mon == 1 & end_is_leap,
29, ifelse(end$mon == 1, 28, ifelse(end$mon %in% 29, ifelse(end$mon == 1, 28, ifelse(end$mon %in%
c(3, 5, 8, 10), 30, 31))) c(3, 5, 8, 10), 30, 31)))
month_length_prior <- ifelse((end$mon - 1) == 1 & month_length_prior <- ifelse((end$mon - 1) == 1 &
start_is_leap, 29, 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), 28, ifelse((end$mon - 1) %in% c(3, 5, 8, 10),
30, 31))) 30, 31)))
month_frac <- ifelse(end$mday > start$mday, (end$mday - month_frac <- ifelse(end$mday > start$mday, (end$mday -
start$mday)/month_length_end, ifelse(end$mday < start$mday)/month_length_end, ifelse(end$mday <
start$mday, (month_length_prior - start$mday)/month_length_prior + start$mday, (month_length_prior - start$mday)/month_length_prior +
end$mday/month_length_end, 0)) end$mday/month_length_end, 0))
result <- months + month_frac result <- months + month_frac
} }
@ -50,18 +53,18 @@ age_calc<-function (dob, enddate = Sys.Date(), units = "years", precise = TRUE)
} }
} }
else if (units == "years") { 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 by = "years", SIMPLIFY = FALSE), length) - 1
if (precise) { if (precise) {
start_length <- ifelse(start_is_leap, 366, 365) start_length <- ifelse(start_is_leap, 366, 365)
end_length <- ifelse(end_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) 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) 1, end$yday)
year_frac <- ifelse(start_day < end_day, (end_day - year_frac <- ifelse(start_day < end_day, (end_day -
start_day)/end_length, ifelse(start_day > end_day, start_day)/end_length, ifelse(start_day > end_day,
(start_length - start_day)/start_length + end_day/end_length, (start_length - start_day)/start_length + end_day/end_length,
0)) 0))
result <- years + year_frac 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.") stop("Unrecognized units. Please choose years, months, or days.")
} }
return(result) return(result)
} }

8
R/cpr_check_function.R
View File

@ -5,11 +5,11 @@
#' @keywords cpr #' @keywords cpr
#' @export #' @export
#' @examples #' @examples
#' cpr_check() #' cpr_check("231045-0637")
cpr_check<-function(x){ cpr_check<-function(x){
#Check validity of CPR number, format ddmmyy-xxxx #Check validity of CPR number, format ddmmyy-xxxx
p1<-as.integer(substr(x,1,1)) p1<-as.integer(substr(x,1,1))
p2<-as.integer(substr(x,2,2)) p2<-as.integer(substr(x,2,2))
p3<-as.integer(substr(x,3,3)) p3<-as.integer(substr(x,3,3))
@ -20,7 +20,7 @@ cpr_check<-function(x){
p8<-as.integer(substr(x,9,9)) p8<-as.integer(substr(x,9,9))
p9<-as.integer(substr(x,10,10)) p9<-as.integer(substr(x,10,10))
p10<-as.integer(substr(x,11,11)) 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") 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) return(result)
} }

8
R/cpr_sex_function.R
View File

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

24
R/dob_extract_cpr_function.R
View File

@ -5,7 +5,7 @@
#' @keywords cpr #' @keywords cpr
#' @export #' @export
#' @examples #' @examples
#' dob_extract_cpr() #' dob_extract_cpr("231045-0637")
dob_extract_cpr<-function(cpr) 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 if (any(substr(cpr,7,7)%in%c(0:9))){stop("Input format should be ddmmyy-xxxx")} # test if input is ddmmyyxxxx
else { else {
dobs<-c() dobs<-c()
a00<-as.numeric(c(0:99)) a00<-as.numeric(c(0:99))
a36<-as.numeric(c(0:36)) a36<-as.numeric(c(0:36))
a57<-as.numeric(c(0:57)) a57<-as.numeric(c(0:57))
b00<-as.numeric(c(0,1,2,3)) b00<-as.numeric(c(0,1,2,3))
b36<-as.numeric(c(4,9)) b36<-as.numeric(c(4,9))
b57<-as.numeric(c(5,6,7,8)) b57<-as.numeric(c(5,6,7,8))
for (x in cpr) for (x in cpr)
{ {
p56<-as.numeric(substr(x,5,6)) p56<-as.numeric(substr(x,5,6))
p8<-as.numeric(substr(x,8,8)) p8<-as.numeric(substr(x,8,8))
birth<-as.Date(substr(x,1,6),format="%d%m%y") 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") 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") 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") 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") 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") 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 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) dobs<-append(dobs,dob)
} }
return(dobs) 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. For age calculations.
} }
\examples{ \examples{
age_calc() ##Kim Larsen
dob<-dob_extract_cpr("231045-0637")
date<-as.Date("2018-09-29")
trunc(age_calc(dob,date))
} }
\keyword{age} \keyword{age}

2
man/cpr_check.Rd
View File

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

2
man/cpr_sex.Rd
View File

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

2
man/dob_extract_cpr.Rd
View File

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