Skip to content

Commit

Permalink
Merge pull request #39 from jsonbecker/fix-logical-check-warning
Browse files Browse the repository at this point in the history 
Removes vector response from if predicate to help R-core move this to an error condition
  • Loading branch information
@jknowles
jknowles committed Oct 16, 2018
2 parents a7a80fd + e6cd931 commit faa6beb
Show file tree
Hide file tree
Showing 10 changed files with 1,120 additions and 1,078 deletions.
65 changes: 33 additions & 32 deletions DESCRIPTION
View file
@@ -1,32 +1,33 @@
Package: eeptools
Type: Package
Title: Convenience Functions for Education Data
Version: 1.2.0
Date: 2018-05-30
Authors@R: c(person(c("Jason", "P."), "Becker", role = c("ctb"),
email = "jason+sitemail@jbecker.co"),
person(c("Jared", "E."), "Knowles", role=c("aut", "cre"),
email="jknowles@gmail.com"))
Description: Collection of convenience functions to make working with
administrative records easier and more consistent. Includes functions to
clean strings, and identify cut points. Also includes three example data
sets of administrative education records for learning how to process records
with errors.
License: GPL-3
Depends:
R (>= 2.15.1),
ggplot2
Imports:
arm,
data.table,
vcd,
maptools
Suggests:
testthat,
stringr,
knitr,
rmarkdown,
MASS
LazyData: true
VignetteBuilder: knitr
RoxygenNote: 6.0.1
Package: eeptools
Type: Package
Title: Convenience Functions for Education Data
Version: 1.2.1
Authors@R: c(person(c("Jason", "P."), "Becker", role = c("ctb"),
email = "jason+sitemail@jbecker.co"),
person(c("Jared", "E."), "Knowles", role=c("aut", "cre"),
email="jknowles@gmail.com"))
Description: Collection of convenience functions to make working with
administrative records easier and more consistent. Includes functions to
clean strings, and identify cut points. Also includes three example data
sets of administrative education records for learning how to process records
with errors.
License: GPL-3
Depends:
R (>= 2.15.1),
ggplot2
Imports:
arm,
data.table,
vcd,
maptools
Suggests:
testthat,
stringr,
knitr,
rmarkdown,
MASS
LazyData: true
VignetteBuilder: knitr
RoxygenNote: 6.0.1
URL: https://github.com/jknowles/eeptools
BugReports: https://github.com/jknowles/eeptools/issues
5 changes: 5 additions & 0 deletions NEWS.md
View file
@@ -1,5 +1,10 @@
# NEWS

## eeptools 1.2.1

### Bug Fixes
- In `max_mis`, there is an `if` predicate that checks if a class is of an invalid type. Because R objects can have multiple classes, this statement relies on the R semantics that the first value of the logical vector returned by the predicate is used. This is a feature R-core is looking to remove as it has considerable performance penalties. This check is now wrapped in `any()`, which evaluates `TRUE` if any value in the logical vector is `TRUE`.

## eeptools 1.2.0

### Added
Expand Down
194 changes: 97 additions & 97 deletions R/age_calc.R
View file
@@ -1,97 +1,97 @@
##' Function to calculate age from date of birth.
##' @description his function calculates age in days, months, or years from a
##' date of birth to another arbitrary date. This returns a numeric vector in
##' the specified units.
##' @param dob a vector of class \code{Date} representing the date of birth/start date
##' @param enddate a vector of class Date representing the when the observation's
##' age is of interest, defaults to current date.
##' @param units character, which units of age should be calculated? allowed values are
##' days, months, and years
##' @param precise logical indicating whether or not to calculate with leap year
##' and leap second precision
##' @return A numeric vector of ages the same length as the dob vector
##' @source This function was developed in part from this response on the R-Help mailing list.
##' @seealso See also \code{\link{difftime}} which this function uses and mimics
##' some functionality but at higher unit levels.
##' @author Jason P. Becker
##' @export
##' @examples
##' a <- as.Date(seq(as.POSIXct('1987-05-29 018:07:00'), len=26, by="21 day"))
##' b <- as.Date(seq(as.POSIXct('2002-05-29 018:07:00'), len=26, by="21 day"))
##'
##' age <- age_calc(a, units='years')
##' age
##' age <- age_calc(a, units='months')
##' age
##' age <- age_calc(a, as.Date('2005-09-01'))
##' age
age_calc <- function(dob, enddate=Sys.Date(), units='months', precise=TRUE){
if (!inherits(dob, "Date") | !inherits(enddate, "Date")){
stop("Both dob and enddate must be Date class objects")
}
if(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
# length(seq(start, end, by='month')) - 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.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.0))
result <- years + year_frac
}else{
result <- years
}
}else{
stop("Unrecognized units. Please choose years, months, or days.")
}
return(result)
}
##' Function to calculate age from date of birth.
##' @description his function calculates age in days, months, or years from a
##' date of birth to another arbitrary date. This returns a numeric vector in
##' the specified units.
##' @param dob a vector of class \code{Date} representing the date of birth/start date
##' @param enddate a vector of class Date representing the when the observation's
##' age is of interest, defaults to current date.
##' @param units character, which units of age should be calculated? allowed values are
##' days, months, and years
##' @param precise logical indicating whether or not to calculate with leap year
##' and leap second precision
##' @return A numeric vector of ages the same length as the dob vector
##' @source This function was developed in part from this response on the R-Help mailing list.
##' @seealso See also \code{\link{difftime}} which this function uses and mimics
##' some functionality but at higher unit levels.
##' @author Jason P. Becker
##' @export
##' @examples
##' a <- as.Date(seq(as.POSIXct('1987-05-29 018:07:00'), len=26, by="21 day"))
##' b <- as.Date(seq(as.POSIXct('2002-05-29 018:07:00'), len=26, by="21 day"))
##'
##' age <- age_calc(a, units='years')
##' age
##' age <- age_calc(a, units='months')
##' age
##' age <- age_calc(a, as.Date('2005-09-01'))
##' age
age_calc <- function(dob, enddate=Sys.Date(), units='months', precise=TRUE){
if (!inherits(dob, "Date") | !inherits(enddate, "Date")) {
stop("Both dob and enddate must be Date class objects")
}
if (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 <- vapply(mapply(seq, as.POSIXct(start), as.POSIXct(end),
by = 'months', SIMPLIFY = FALSE),
length, FUN.VALUE = length(start)) - 1
# length(seq(start, end, by='month')) - 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.0))
result <- months + month_frac
}else{
result <- months
}
} else if (units == 'years') {
years <- vapply(mapply(seq, as.POSIXct(start), as.POSIXct(end),
by = 'years', SIMPLIFY = FALSE),
length, FUN.VALUE = length(start)) - 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.0))
result <- years + year_frac
}else{
result <- years
}
}else{
stop("Unrecognized units. Please choose years, months, or days.")
}
return(result)
}

0 comments on commit faa6beb

Please sign in to comment.