I like the new difftime functionality. Here's a dataframe of 5k run times:
> r5k
race date totaltime pace mile
1 RUDOLPH 2004-12-03 19:00:00 27.76667 mins 8.937224 mins 3.106856
2 RUDOLPH 2005-12-02 18:30:00 25.28333 mins 8.137916 mins 3.106856
3 FROSTBITE 2005-12-10 07:00:00 24.75000 mins 7.966253 mins 3.106856
4 JUDICATA 2006-03-04 08:00:00 25.51667 mins 8.213019 mins 3.106856
5 TOM KING 2006-03-18 07:00:00 23.71667 mins 7.633655 mins 3.106856
6 RUDOLPH 2006-12-01 18:30:00 24.21667 mins 7.794589 mins 3.106856
7 FATHERHOOD 2006-06-24 07:00:00 23.51667 mins 7.569281 mins 3.106856
8 FIRECRACKER 2006-07-04 07:00:00 23.53333 mins 7.574646 mins 3.106856
9 FANGTASTIC 2007-02-10 10:00:00 22.86667 mins 7.360067 mins 3.106856
But I thought the formatting could use some help, so I re-wrote
base::format.difftime and added support for the conversion
specifications '%W', '%d', '%H', '%M', and '%S' (borrowed from
strftime). It also honors getOption("digits") and
getOption(digits.secs") for '%S'. I added support for a "format"
attribute as well:
> attr(r5k$pace,"format") <- "%M:%S"
> attr(r5k$totaltime,"format") <- "%M:%S"
> r5k
race date totaltime pace mile
1 RUDOLPH 2004-12-03 19:00:00 27:46 08:56 3.106856
2 RUDOLPH 2005-12-02 18:30:00 25:17 08:08 3.106856
3 FROSTBITE 2005-12-10 07:00:00 24:45 07:58 3.106856
4 JUDICATA 2006-03-04 08:00:00 25:31 08:13 3.106856
5 TOM KING 2006-03-18 07:00:00 23:43 07:38 3.106856
6 RUDOLPH 2006-12-01 18:30:00 24:13 07:48 3.106856
7 FATHERHOOD 2006-06-24 07:00:00 23:31 07:34 3.106856
8 FIRECRACKER 2006-07-04 07:00:00 23:32 07:34 3.106856
9 FANGTASTIC 2007-02-10 10:00:00 22:52 07:22 3.106856
Formats can also be passed as an argument:
> format(sum(r5k$totaltime),"%W:%d:%H:%M:%S")
[1] "00:00:03:41:10"
> format(sum(r5k$totaltime),"%W:%d")
[1] "00:0.1535880"
> format(sum(r5k$totaltime),"%W")
[1] "0.0219411"
My code is a little verbose, and I'm looking for some optimizations. If
anyone has comments, suggestions, I'd be much obliged.
Here's the code:
format.difftime <- function (x,format=NULL,...)
{
# Look for a "format" attribute, if null then return basics
if (is.null(format)){
if (is.null(attr(x,"format")))
return(paste(format(unclass(x),...), units(x)))
else
format <- rep(attr(x,"format"),length(x))
} else {
format <- rep(format,length(x))
}
units(x)<-'secs'
rem <- unclass(x)
w <- d <- h <- m <- s <- array(0,length(x))
lunit <- ""
if (length(grep('%W',format,fixed=TRUE)) > 0 ){
w <- rem %/% (7 * 86400)
rem <- rem - w * 7 * 86400
lunit <- "weeks"
}
if (length(grep('%d',format,fixed=TRUE)) > 0){
d <- rem %/% 86400
rem <- rem - d * 86400
lunit <- "days"
}
if (length(grep('%H',format,fixed=TRUE)) > 0){
h <- rem %/% 3600
rem <- rem - h * 3600
lunit <- "hours"
}
if (length(grep('%M',format,fixed=TRUE)) > 0){
m <- rem %/% 60
rem <- rem - m * 60
lunit <- "mins"
}
if (length(grep('%S',format,fixed=TRUE)) > 0){
s <- rem
rem <- rem - s
lunit <- "secs"
}
# Find precision formatting
digits <-
ifelse(is.null(getOption("digits")),
0,
as.integer(getOption("digits"))
)
digits.secs <-
ifelse(is.null(getOption("digits.secs")),
0,
as.integer(getOption("digits.secs"))
)
# Place remainder in last unit we saw.
# Also set formatting.
wf <- df <- hf <- mf <- sf <- "%02.f"
if (lunit != ""){
if (lunit == "weeks"){
w <- w + rem / (7 * 86400)
wf <- paste("%02.",digits,"f",sep='')
} else if (lunit == "days"){
d <- d + rem / 86400
df <- paste("%02.",digits,"f",sep='')
} else if (lunit == "hours"){
h <- h + rem / 3600
hf <- paste("%02.",digits,"f",sep='')
} else if (lunit == "mins"){
m <- m + rem / 60
mf <- paste("%02.",digits,"f",sep='')
} else if (lunit == "secs"){
sf <- paste("%02.",digits.secs,"f",sep='')
}
}
# Do substitution
for (i in 1:length(format)){
format[i] <- gsub('%W',sprintf(wf,w[i]),format[i],fixed=TRUE)
format[i] <- gsub('%d',sprintf(df,d[i]),format[i],fixed=TRUE)
format[i] <- gsub('%H',sprintf(hf,h[i]),format[i],fixed=TRUE)
format[i] <- gsub('%M',sprintf(mf,m[i]),format[i],fixed=TRUE)
format[i] <- gsub('%S',sprintf(sf,s[i]),format[i],fixed=TRUE)
}
format
}
Cheers,
Jeff
--
http://biostat.mc.vanderbilt.edu/JeffreyHorner
______________________________________________
R-devel@r-project.org mailing list
https://stat.ethz.ch/mailman/listinfo/r-devel
