Skip to content

Commit

Permalink
Merge pull request #19 from poissonconsulting/f-title
Browse files Browse the repository at this point in the history
  • Loading branch information
joethorley authored Aug 8, 2024
2 parents fd45472 + 442ab9c commit ef1527f
Show file tree
Hide file tree
Showing 51 changed files with 774 additions and 181 deletions.
9 changes: 4 additions & 5 deletions DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -10,11 +10,10 @@ Authors@R: c(
comment = c(ORCID = "0000-0003-4470-8361")),
person("Poisson Consulting", role = c("cph", "fnd"))
)
Description: Tracks elapsed clock time using a `hms::hms()` scalar, which
if running has an attribute named start that specifies the system time
when the timer was started. The elapsed time is the value of the
scalar plus the difference between the current system time and the
system time when the timer was started.
Description: Tracks elapsed clock time using a `hms::hms()` scalar.
It was was originally developed to time Bayesian model runs.
It should not be used to estimate how long extremely fast code takes to execute
as the package code adds a small time cost.
License: MIT + file LICENSE
URL: https://github.com/poissonconsulting/hmstimer,
https://poissonconsulting.github.io/hmstimer/
Expand Down
3 changes: 3 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -1,18 +1,21 @@
# Generated by roxygen2: do not edit by hand

export("tmr_title<-")
export(local_timer)
export(tmr_ceiling)
export(tmr_elapsed)
export(tmr_floor)
export(tmr_format)
export(tmr_is_started)
export(tmr_is_stopped)
export(tmr_is_titled)
export(tmr_print)
export(tmr_reset)
export(tmr_round)
export(tmr_start)
export(tmr_stop)
export(tmr_timer)
export(tmr_title)
export(with_timer)
import(hms)
importFrom(lifecycle,deprecated)
3 changes: 2 additions & 1 deletion R/ceiling.R
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@
#' tmr_ceiling(tmr_timer(122.1))
tmr_ceiling <- function(x) {
start <- tmr_is_started(x)
title <- tmr_title(x)
x <- ceiling(as.numeric(tmr_elapsed(x)))
tmr_timer(x, start = start)
tmr_timer(x, start = start, title = title)
}
27 changes: 20 additions & 7 deletions R/chk.R
Original file line number Diff line number Diff line change
Expand Up @@ -25,21 +25,34 @@ chk_seconds <- function(seconds) {
err("`seconds` must not be a missing value.")
}

chk_start <- function(start) {
if (is.logical(start) && length(start) == 1L && !is.na(start)) {
chk_title <- function(title) {
if (is.null(title) || (is.character(title) && length(title) == 1L && !is.na(title))) {
return(invisible())
}
if (!is.character(title)) err("`title` must be numeric.")
if (length(title) != 1L) err("`title` must be a scalar.")
err("`title` must not be a missing value.")
}

chk_flag <- function(x, name) {
if (is.logical(x) && length(x) == 1L && !is.na(x)) {
return(invisible())
}
if (!is.logical(start)) err("`start` must be class logical.")
if (length(start) != 1L) err("`start` must be a scalar.")
err("`start` must not be a missing value.")
if (!is.logical(x)) err("`", name, "` must be class logical.")
if (length(x) != 1L) err("`", name, "` must be a scalar.")
err("`", name, "` must not be a missing value.")
}

chk_start <- function(start) {
chk_flag(start, "start")
}

chk_x <- function(x) {
if (is.hms(x) && length(x) == 1L && !is.na(x)) {
if (is_hms(x) && length(x) == 1L && !is.na(x)) {
return(invisible())
}

if (!is.hms(x)) err("`x` must be class hms.")
if (!is_hms(x)) err("`x` must be class hms.")
if (length(x) != 1L) err("`x` must be a scalar.")
err("`x` must not be a missing value.")
}
3 changes: 2 additions & 1 deletion R/floor.R
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@
#' tmr_floor(tmr_timer(122.1))
tmr_floor <- function(x) {
start <- tmr_is_started(x)
title <- tmr_title(x)
x <- floor(as.numeric(tmr_elapsed(x)))
tmr_timer(x, start = start)
tmr_timer(x, start = start, title = title)
}
11 changes: 9 additions & 2 deletions R/format.R
Original file line number Diff line number Diff line change
Expand Up @@ -12,15 +12,22 @@
#' @examples
#' tmr_format(tmr_timer(61.66))
#' tmr_format(tmr_timer(61.66), digits = 0)
tmr_format <- function(x, digits = 3) {
tmr_format <- function(x, digits = 3, ..., print_title = TRUE) {
chk_digits(digits)
rlang::check_dots_empty()

if (digits < 0) err("`digits` must not be negative.")

x <- tmr_round(x, digits = digits)
msecs <- as.numeric(x) - floor(as.numeric(x))
x <- tmr_floor(x)
title <- tmr_title(x)
x <- as.character(x)
msecs <- formatC(msecs, digits = digits, format = "f")
msecs <- substr(msecs, 2, nchar(msecs))
paste0(x, msecs)
x <- paste0(x, msecs)
if (print_title) {
x <- paste_title(x, title)
}
x
}
5 changes: 0 additions & 5 deletions R/internal.R

This file was deleted.

13 changes: 13 additions & 0 deletions R/is-titled.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,13 @@
#' Is hms Timer Title
#'
#' Tests if a [hms_timer()] has a title (as indicated by the
#' presence of an attribute named start).
#' @inheritParams params
#' @return A flag (TRUE or FALSE).
#' @export
#' @examples
#' tmr_is_titled(tmr_timer())
#' tmr_is_titled(tmr_timer(title = "my timer"))
tmr_is_titled <- function(x) {
tmr_title(x) != ""
}
20 changes: 18 additions & 2 deletions R/local-timer.R
Original file line number Diff line number Diff line change
Expand Up @@ -15,12 +15,28 @@
#' 10
#' }
#' fun()
local_timer <- function(.local_envir = rlang::caller_env()) {
local_timer <- function(..., title = "", srcref = TRUE, .local_envir = rlang::caller_env()) {
rlang::check_dots_empty()
chk_title(title)
chk_env(.local_envir)
chk_flag(srcref, "srcref")

rlang::check_installed("withr", reason = "to create a local_timer().")

tmr <- tmr_start(as_hms(0))

if (srcref) {
caller <- sys.call()
srcref <- utils::getSrcref(caller)
file <- utils::getSrcFilename(srcref)
file_line <- paste0(file, ":", srcref[[1]])

if (!is.null(title) && title != "") {
file_line <- paste0(file_line, " - ", title)
}
} else {
file_line <- title
}
tmr <- tmr_start(as_hms(0), title = file_line)
withr::defer(message(tmr_format(tmr)), envir = .local_envir)
invisible(tmr)
}
32 changes: 25 additions & 7 deletions R/params.R
Original file line number Diff line number Diff line change
@@ -1,11 +1,29 @@
#' Parameter Descriptions for hmstimer Functions
#' Parameter Descriptions
#'
#' @param .local_envir The environment to use for scoping.
#' @param code Code to time.
#' @param digits A whole number of the number of decimal places.
#' Default parameter descriptions which may be overridden in individual
#' functions.
#'
#' A flag is a non-missing logical scalar.
#'
#' A string is a non-missing character scalar.
#'
#' A count is a non-missing non-negative integer scalar or double
#' scalar with no fractional part.
#
#' @param code A line or block of R code.
#' @param digits A count of the number of decimal places.
#' @param print_title A flag specifying whether to print the title.
#' @param seconds A non-negative numeric scalar of the initial number of seconds.
#' @param start A flag indicating whether to start the timer.
#' @param srcref A flag specifying whether to print the source reference.
#' @param start A flag specifying whether to start the timer.
#' @param title A string of the title.
#' @param value A string of the title.
#' @param x A [hms_timer()].
#' @param .local_envir The environment to use for scoping.
#' @inheritParams rlang::args_dots_empty
#' @keywords internal
#' @name params
NULL
#' @aliases parameters arguments args
#' @usage NULL
# nocov start
params <- function(...) NULL
# nocov end
14 changes: 12 additions & 2 deletions R/print.R
Original file line number Diff line number Diff line change
Expand Up @@ -13,10 +13,17 @@
#' @examples
#' x <- tmr_start(tmr_timer())
#' tmr_print(x)
tmr_print <- function(x) {
tmr_print <- function(x, ..., print_title = TRUE) {
chk_x(x)
rlang::check_dots_empty()
chk_flag(print_title, "print_title")

if (!tmr_is_started(x)) {
print(x)
time <- format(x)
if (print_title) {
time <- paste_title(time, tmr_title(x))
}
print(time)
return(invisible(x))
}

Expand All @@ -29,6 +36,9 @@ tmr_print <- function(x) {
sys_time <- format(structure(sys_time, class = "POSIXct", tzone = "UTC"), "%T")
time_passed <- paste(start, " (+", time_passed, " => ", sys_time, ")", sep = "")

if (print_title) {
time_passed <- paste_title(time_passed, tmr_title(x))
}
print(time_passed)
return(invisible(x))
}
3 changes: 2 additions & 1 deletion R/reset.R
Original file line number Diff line number Diff line change
Expand Up @@ -12,5 +12,6 @@
#' tmr_reset(tmr)
tmr_reset <- function(x, seconds = 0) {
start <- tmr_is_started(x)
tmr_timer(seconds = seconds, start = start)
title <- tmr_title(x)
tmr_timer(seconds = seconds, start = start, title = title)
}
3 changes: 2 additions & 1 deletion R/round.R
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,7 @@
#' tmr_round(tmr_timer(121), -2) # 121 is rounded to 100 seconds
tmr_round <- function(x, digits = 0) {
start <- tmr_is_started(x)
title <- tmr_title(x)
x <- round(as.numeric(tmr_elapsed(x)), digits = digits)
tmr_timer(x, start = start)
tmr_timer(x, start = start, title = title)
}
7 changes: 6 additions & 1 deletion R/start.R
Original file line number Diff line number Diff line change
Expand Up @@ -14,11 +14,16 @@
#' print(tmr_elapsed(tmr))
#' Sys.sleep(0.01)
#' print(tmr_elapsed(tmr))
tmr_start <- function(x) {
tmr_start <- function(x, ..., title = NULL) {
rlang::check_dots_empty()
chk_title(title)
if (tmr_is_started(x)) {
wrn("`x` is already started.")
return(x)
}
attr(x, "start") <- as.double(Sys.time())
if (!tmr_is_titled(x) && !is.null(title)) {
tmr_title(x) <- title
}
x
}
2 changes: 2 additions & 0 deletions R/stop.R
Original file line number Diff line number Diff line change
Expand Up @@ -18,7 +18,9 @@ tmr_stop <- function(x) {
wrn("`x` is already stopped.")
return(x)
}
title <- tmr_title(x)
x <- tmr_elapsed(x)
attr(x, "start") <- NULL
tmr_title(x) <- title
x
}
12 changes: 8 additions & 4 deletions R/timer.R
Original file line number Diff line number Diff line change
Expand Up @@ -7,16 +7,20 @@
#' @export
#'
#' @examples
#' tmr <- tmr_timer()
#' print(tmr)
#' class(tmr)
tmr_timer <- function(seconds = 0, start = FALSE) {
#' tmr_timer()
#' tmr_timer(1, start = TRUE, title = "my timer")
#' class(tmr_timer(2))
#' str(tmr_timer(2, start = TRUE, title = "a timer"))
tmr_timer <- function(seconds = 0, start = FALSE, ..., title = "") {
chk_seconds(seconds)
chk_start(start)
rlang::check_dots_empty()
chk_title(title)

seconds <- as.double(seconds)

x <- as_hms(seconds)
attr(x, "title") <- unname(title)
if (start) x <- tmr_start(x)
x
}
41 changes: 41 additions & 0 deletions R/title.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,41 @@
#' Get Title hms Timer
#'
#' Returns a flag (character vector) of the title.
#'
#' @inheritParams params
#' @return A flag of the title.
#' @seealso [tmr_title<-()]
#' @export
#' @examples
#' tmr_title(tmr_timer())
#' tmr_title(tmr_timer(title = ""))
#' tmr_title(tmr_timer(title = "A Title"))
tmr_title <- function(x) {
title <- attr(x, "title")
if (is.null(title)) {
return("")
}
unname(title)
}

#' Set Title hms Timer
#'
#' Sets the title of a [hms_timer()].
#'
#' @inheritParams params
#' @return A copy of the [hms_timer()] with the new title.
#' @seealso [tmr_title()]
#' @export
#' @examples
#' tmr <- tmr_timer(title = "A title")
#' tmr_print(tmr)
#' tmr_title(tmr) <- "A different title"
#' tmr_print(tmr)
#' tmr_title(tmr) <- NULL
#' tmr_print(tmr)
`tmr_title<-` <- function(x, value) {
chk_title(value)
value <- unname(value)
attr(x, "title") <- value
x
}
11 changes: 10 additions & 1 deletion R/utils.R
Original file line number Diff line number Diff line change
@@ -1,5 +1,14 @@
is.hms <- function(x) inherits(x, "hms")
as_hms <- function(x) {
hms::new_hms(x)
}

err <- function(...) stop(..., call. = FALSE)

wrn <- function(...) warning(..., call. = FALSE)

paste_title <- function(x, title) {
if (is.null(title) || !nchar(title)) {
return(x)
}
paste0(x, " [", title, "]")
}
13 changes: 11 additions & 2 deletions R/with-timer.R
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
#' With Timer
#'
#' @inheritParams params
#' @param title A flag specifying whether to add a title based on code.
#'
#' @return The result of executing the code.
#' @seealso [local_timer()]
Expand All @@ -19,7 +20,15 @@
#' }
#' 20
#' })
with_timer <- function(code) {
local_timer()
with_timer <- function(code, ..., title = FALSE, srcref = FALSE) {
rlang::check_dots_empty()
chk_flag(title)

if (title) {
title <- rlang::expr_label(rlang::enexpr(code))
} else {
title <- ""
}
local_timer(title = title, srcref = srcref)
force(code)
}
Loading

0 comments on commit ef1527f

Please sign in to comment.