3
\$\begingroup\$

I've written this brief function for calculating which calendar year a student would be in Year 1 based on their DOB (date of birth). In 1998 there was a change in the DOB cut points for starting Year 1, hence the need for a function.

year1 <- function(x){
    if(x <= as.Date("1996-12-31")) {out <- as.numeric(format(x, "%Y")) +6}
    if(x >= as.Date("1997-07-01")) {ifelse(as.numeric(format(x, "%m")) >=07 , out <- as.numeric(format(as.Date(x), "%Y")) + 7, out <- as.numeric(format(x, "%Y")) + 6)} 
    if(x >= as.Date("1997-01-01") & x <= as.Date("1997-06-30")) {out <- 2003}
    return(out)
}

An example of the results:

> year1(as.Date("1996-02-15"))
[1] 2002
> year1(as.Date("1999-02-15"))
[1] 2006

I plan to run it like this:

> test <- c(as.Date("1985-09-15"),as.Date("1999-02-15"),as.Date("2004-08-15"))
> sapply(test,year1)
[1] 1991 2006 2011

I have a lot of data to run this over, and the use of so many ifs and assigning the result to out just to write it seems pretty redundant, but I couldn't think of a better way to do it.

\$\endgroup\$
  • \$\begingroup\$ I see, primary school in Australia for children six to seven years old is called year 1. \$\endgroup\$ – minopret Mar 22 '12 at 4:32
  • \$\begingroup\$ it's different in different states, in WA it used to be a case that at the start (say January) of Year 1 kids were aged between 5 and 6, with the change in 1997 it is now the case that kids are aged between 5.5 and 6.5 at the start of Year 1. \$\endgroup\$ – nzcoops Mar 22 '12 at 4:36
2
\$\begingroup\$

Your first and third condition can be collapsed into one, which just leaves a single split point. As such, you can use ifelse.

year1 <- function(x) {
    year <- as.numeric(format(x, "%Y"))
    ifelse(x <= as.Date("1997-06-30"), year+6, year+7)
}

This is also vectorized, so you can use it like:

test <- as.Date(c("1985-09-15", "1999-02-15", "2004-08-15", "1996-02-15"))
year1(test)

which gives

> year1(test)
[1] 1991 2006 2011 2002

EDIT:

The code I gave was wrong; it did not agree with the original code in many of the cases. Here is an updated version which does:

year1 <- function(x){
    year <- as.numeric(format(x, "%Y"))
    ifelse(x <= as.Date("1997-06-30"),
           year + 6,
           ifelse(as.numeric(format(x, "%m")) >=07 , 
                  year + 7, 
                  year + 6))
}

You can squeeze a little more out of it by not bothering with the assignment to year and factoring that out of the ifelse

year1 <- function(x){
    as.numeric(format(x, "%Y")) +
    ifelse(x <= as.Date("1997-06-30"),
           6,
           ifelse(as.numeric(format(x, "%m")) >=07 , 
                  7, 
                  6))
}

Benchmarking:

year1.nzcoops <- function(x){
    if(x <= as.Date("1996-12-31")) {out <- as.numeric(format(x, "%Y")) +6}
    if(x >= as.Date("1997-07-01")) {ifelse(as.numeric(format(x, "%m")) >=07 , out <- as.numeric(format(as.Date(x), "%Y")) + 7, out <- as.numeric(format(x, "%Y")) + 6)} 
    if(x >= as.Date("1997-01-01") & x <= as.Date("1997-06-30")) {out <- 2003}
    return(out)
}
year1.Brian <- function(x){
    year <- as.numeric(format(x, "%Y"))
    ifelse(x <= as.Date("1997-06-30"),
           year + 6,
           ifelse(as.numeric(format(x, "%m")) >=07 , 
                  year + 7, 
                  year + 6))
}

year1.BrianB <- function(x){
    as.numeric(format(x, "%Y")) +
    ifelse(x <= as.Date("1997-06-30"),
           6,
           ifelse(as.numeric(format(x, "%m")) >=07 , 
                  7, 
                  6))
}

year1.minopret <- function(dob) as.numeric(format(dob, "%Y")) + 6 +
    (as.Date("1997-07-01") <= dob & 7 <= as.numeric(format(dob, "%m")))

More comprehensive test data:

test <- as.Date("1985-09-15")+(0:10000)

Checking results:

res.nzcoops <- sapply(test, year1.nzcoops)
res.Brian <- year1.Brian(test)
res.BrianB <- year1.BrianB(test)
res.minopret <- year1.minopret(test)

> identical(res.nzcoops, res.Brian)
[1] TRUE
> identical(res.nzcoops, res.BrianB)
[1] TRUE
> identical(res.nzcoops, res.minopret)
[1] TRUE

Timing comparisons:

> library("rbenchmark")
> benchmark(sapply(test, year1.nzcoops),
+           year1.Brian(test),
+           year1.BrianB(test),
+           year1.minopret(test),
+           order = "relative",
+           replications = 10)
                         test replications elapsed   relative user.self
4        year1.minopret(test)           10    0.12   1.000000      0.12
3          year1.BrianB(test)           10    0.14   1.166667      0.14
2           year1.Brian(test)           10    0.16   1.333333      0.14
1 sapply(test, year1.nzcoops)           10   74.95 624.583333     74.85
  sys.self user.child sys.child
4     0.00         NA        NA
3     0.00         NA        NA
2     0.01         NA        NA
1     0.02         NA        NA
\$\endgroup\$
  • \$\begingroup\$ Cheers, I have so many timelines written down working out start/finish ages for difference calendar years and school years I couldn't see the forest for the trees. \$\endgroup\$ – nzcoops Mar 22 '12 at 6:36
3
\$\begingroup\$

I think this is equivalent to your function.

year1 <- function(dob) as.numeric(format(dob, "%Y")) + 6 +
    (as.Date("1997-07-01") <= dob & 7 <= as.numeric(format(dob, "%m")))

You would run it like this.

> test <- c(as.Date("1985-09-15"),as.Date("1999-02-15"),as.Date("2004-08-15"))
> year1(test)
\$\endgroup\$
  • \$\begingroup\$ It is also worth pointing out that this function is vectorized where the original wasn't. You demonstrate that in the example, but I wanted to point it out explicitly. \$\endgroup\$ – Brian Diggs Mar 22 '12 at 5:38

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.