├── src ├── Makevars.win ├── do_nothing.h ├── Makevars.in ├── nanotimer_windows.h ├── nanotimer_gettimeofday.h ├── do_nothing.c ├── nanotimer_rtposix.h ├── nanotimer_clock_gettime.h ├── init.c ├── nanotimer_macosx.h ├── sexp_macros.h ├── config.h.in └── nanotimer.c ├── .dict.rds ├── .github ├── FUNDING.yml ├── pull_request_template.md ├── issue_template.md ├── security.md └── CONTRIBUTING.md ├── cleanup ├── examples ├── null.R ├── weird_expr.R ├── 1plus1.R ├── native.c ├── overhead.R ├── order_expr.R ├── output.R ├── scaling.R ├── units.R ├── system_time.R ├── check.R ├── native.R ├── seq.R ├── funcall.R ├── simple_lm.R ├── relative.R ├── types.R ├── dispatchspeed.R ├── multcomp.R ├── stringdispatch.R └── callnextmethod.R ├── tools ├── roxygenize ├── run-tests └── set-version ├── LICENSE ├── .Rbuildignore ├── .gitignore ├── R ├── nanotime.R ├── microtiming_precision.R ├── rbind.R ├── zzz.R ├── boxplot.R ├── print.R ├── autoplot.R ├── summary.R ├── internal.R └── microbenchmark.R ├── .travis.yml ├── man ├── get_nanotime.Rd ├── coalesce.Rd ├── boxplot.microbenchmark.Rd ├── microtiming_precision.Rd ├── find_prefix.Rd ├── convert_to_unit.Rd ├── summary.microbenchmark.Rd ├── determine_unit.Rd ├── autoplot.microbenchmark.Rd ├── print.microbenchmark.Rd └── microbenchmark.Rd ├── README.md ├── NAMESPACE ├── DESCRIPTION ├── tests └── doRUnit.R ├── Makefile ├── inst └── unitTests │ └── runit_test_regression.R ├── configure.ac └── do /src/Makevars.win: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.dict.rds: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/joshuaulrich/microbenchmark/HEAD/.dict.rds -------------------------------------------------------------------------------- /.github/FUNDING.yml: -------------------------------------------------------------------------------- 1 | github: [joshuaulrich] 2 | tidelift: "cran/microbenchmark" 3 | -------------------------------------------------------------------------------- /cleanup: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | rm config.log config.status src/config.h src/Makevars 4 | -------------------------------------------------------------------------------- /examples/null.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | print(microbenchmark(NULL, times=1000000L)) 4 | -------------------------------------------------------------------------------- /tools/roxygenize: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 3 | library("methods") 4 | library("roxygen2") 5 | roxygenize("pkg") 6 | -------------------------------------------------------------------------------- /examples/weird_expr.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | b <- microbenchmark({1+1}, (1+1), times=100L) 4 | print(b) 5 | -------------------------------------------------------------------------------- /src/do_nothing.h: -------------------------------------------------------------------------------- 1 | #ifndef __DO_NOTHING_H__ 2 | #define __DO_NOTHING_H__ 3 | 4 | extern int do_nothing(void); 5 | #endif 6 | -------------------------------------------------------------------------------- /examples/1plus1.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | microbenchmark(1 + 1, 1 + -1, 1 + --1, 1 + ---1, 4 | times=1000L, control=list(order="block")) 5 | -------------------------------------------------------------------------------- /examples/native.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | SEXP do_nothing(SEXP s_in) { 7 | return s_in; 8 | } 9 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | YEAR: 2010-2014 2 | COPYRIGHT HOLDER: Olaf Mersmann 3 | YEAR: 2012 4 | COPYRIGHT HOLDER: Ari Friedman 5 | YEAR: 2012 6 | COPYRIGHT HOLDER: Rainer Hurling 7 | YEAR: 2011 8 | COPYRIGHT HOLDER: Claudia Beleites 9 | -------------------------------------------------------------------------------- /tools/run-tests: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | ## -*- mode:r -*- 3 | 4 | library("methods") 5 | library("testthat") 6 | library("microbenchmark") 7 | 8 | test_dir(file.path(system.file(package="microbenchmark"), "tests")) 9 | -------------------------------------------------------------------------------- /examples/overhead.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | res <- microbenchmark(NULL, times=100000L) 4 | times <- res$time 5 | long <- which(times > 2.5 * median(times)) 6 | 7 | print(median(times[long]) - median(times[-long])) 8 | -------------------------------------------------------------------------------- /examples/order_expr.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | b <- microbenchmark(b=1, c=2, a=3, times=1000L) 4 | print(b) 5 | 6 | b1 <- microbenchmark(b=1, a=2, times=1000L) 7 | b2 <- microbenchmark(d=3, c=4, times=250L) 8 | print(rbind(b1, b2)) 9 | -------------------------------------------------------------------------------- /examples/output.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | b <- rbind(microbenchmark(1, -1, runif(10), times=200L), 4 | microbenchmark(2, -2, runif(20), times=100L)) 5 | print(b) 6 | print(b, unit="eps") 7 | print(b, unit="t", order="neval") 8 | -------------------------------------------------------------------------------- /examples/scaling.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | exprs <- list() 4 | for (n in 10^(3:7)) { 5 | name <- sprintf("n%i", n) 6 | assign(name, as.numeric(1:n)) 7 | exprs[[name]] <- bquote(f(.(as.name(name)))) 8 | } 9 | 10 | f <- sum 11 | res <- microbenchmark(list=exprs, times=100L) 12 | print(res, unit="relative") 13 | -------------------------------------------------------------------------------- /src/Makevars.in: -------------------------------------------------------------------------------- 1 | PKG_LIBS = @MB_LIBS@ 2 | ## 3 | ## Some compilers (in C99 mode) will not define _POSIX_C_SOURCE for 4 | ## us. In that case time.h does not define the required structures. So 5 | ## for the sake of easy installation, we manually set it if it is not 6 | ## set. 7 | ## 8 | PKG_CPPFLAGS = -D_POSIX_C_SOURCE=200112L @DEFS@ 9 | -------------------------------------------------------------------------------- /.github/pull_request_template.md: -------------------------------------------------------------------------------- 1 | Please review the [contributing guide](CONTRIBUTING.md) before submitting your pull request. Please pay special attention to the [pull request](CONTRIBUTING.md#want-to-submit-a-pull-request) and [commit message](CONTRIBUTING.md#commit-messages) sections. Thanks for your contribution and interest in the project! 2 | -------------------------------------------------------------------------------- /examples/units.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | b_unit <- microbenchmark(1+1, 1-1, 1, -1, 1e1, unit="relative") 4 | b_none <- microbenchmark(1+1, 1-1, 1, -1, 1e1) 5 | 6 | summary(b_unit) 7 | print(b_unit, order="median") 8 | print(b_unit, unit="t") 9 | 10 | options("microbenchmark.unit"="f") 11 | print(b_none) 12 | print(b_none, unit="eps") 13 | -------------------------------------------------------------------------------- /src/nanotimer_windows.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | static nanotime_t get_nanotime(void) { 4 | LARGE_INTEGER time_var, frequency; 5 | QueryPerformanceCounter(&time_var); 6 | QueryPerformanceFrequency(&frequency); 7 | 8 | /* Convert to nanoseconds */ 9 | return (nanotime_t)(1.0e9 * time_var.QuadPart / frequency.QuadPart); 10 | } 11 | -------------------------------------------------------------------------------- /.github/issue_template.md: -------------------------------------------------------------------------------- 1 | ### Description 2 | 3 | [Describe the issue] 4 | 5 | ### Expected behavior 6 | 7 | [Describe the behavior/output you expected] 8 | 9 | ### Minimal, reproducible example 10 | 11 | ```r 12 | [Insert sample data and code] 13 | ``` 14 | 15 | ### Session Info 16 | 17 | ```r 18 | [Insert your sessionInfo() output] 19 | ``` 20 | 21 | -------------------------------------------------------------------------------- /examples/system_time.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | n <- 100000 4 | x <- runif(n) 5 | y <- runif(n) 6 | 7 | k <- 10000L 8 | s <- 1:k 9 | 10 | ## Measure overhead: 11 | t0 <- system.time(for (i in 1:k) NULL) 12 | t1 <- system.time(for (i in 1:k) crossprod(x, y)) 13 | tt <- (t1 - t0) / k 14 | 15 | t2 <- microbenchmark(crossprod(x, y), times=100L) 16 | -------------------------------------------------------------------------------- /examples/check.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | my_check <- function(values) { 4 | all(sapply(values[-1], function(x) identical(values[[1]], x))) 5 | } 6 | 7 | f <- function(a, b) 8 | 2 + 2 9 | 10 | a <- 2 11 | microbenchmark(2 + 2, 2 + a, f(2, a), f(2, 2), check=my_check) 12 | 13 | a <- 3 14 | microbenchmark(2 + 2, 2 + a, f(2, a), f(2, 2), check=my_check) 15 | -------------------------------------------------------------------------------- /examples/native.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | dyn.load("native.so") 4 | 5 | do_nothing <- getNativeSymbolInfo("do_nothing") 6 | 7 | res <- microbenchmark(.Call(do_nothing, NULL), 8 | .Call("do_nothing", NULL), 9 | times=100L, 10 | control=list(warmup=2^20)) 11 | print(res) 12 | print(relative_slowdown(res)) 13 | -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^dist/ 2 | ^do 3 | ^examples$ 4 | ^.dict.rds 5 | ^.*\.cache$ 6 | 7 | ^.*\.Rcheck$ 8 | ^.*\.tar.gz$ 9 | ^.*\.patch$ 10 | ^.*\.notes$ 11 | 12 | ^src/.*\.o 13 | ^src/.*\.so 14 | 15 | ^.*\.Rproj$ 16 | ^\.Rproj\.user$ 17 | ^\.git 18 | ^\.gitignore 19 | ^.*\.orig$ 20 | \.md$ 21 | \.Rmd$ 22 | ^release-checklist.md$ 23 | 24 | README.md 25 | 26 | .travis.yml 27 | Makefile 28 | ^\.sw*$ 29 | -------------------------------------------------------------------------------- /examples/seq.R: -------------------------------------------------------------------------------- 1 | library("reshape") 2 | library("ggplot2") 3 | library("microbenchmark") 4 | 5 | n <- 1000L 6 | x <- 1:n 7 | 8 | res <- microbenchmark(seq_along(x), 9 | seq_len(n), 10 | 1:n, 11 | 1:length(x), 12 | seq(1L, n), 13 | seq.int(1L, n), 14 | times=1000L) 15 | print(res, unit="ns") 16 | -------------------------------------------------------------------------------- /src/nanotimer_gettimeofday.h: -------------------------------------------------------------------------------- 1 | # include 2 | 3 | static const nanotime_t nanoseconds_in_second = 1000000000LL; 4 | 5 | static nanotime_t get_nanotime(void) { 6 | nanotime_t nt; 7 | struct timeval tv; 8 | if (gettimeofday(&tv, NULL)) { 9 | nt = tv.tv_sec * nanoseconds_in_second; 10 | nt += tv.tv_usec * 1000LL; 11 | } else { 12 | nt = 0; 13 | } 14 | return nt; 15 | } 16 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # History and data files 2 | .Rhistory 3 | .Rapp.history 4 | .RData 5 | 6 | # RStudio files 7 | .Rproj.user 8 | *.Rproj 9 | 10 | # produced vignettes 11 | vignettes/*.html 12 | vignettes/*.pdf 13 | 14 | # knitr and R markdown 15 | /*_cache/ 16 | /cache/ 17 | *.utf8.md 18 | *.knit.md 19 | 20 | # object and shared objects 21 | *.o 22 | *.so 23 | 24 | # vim 25 | *.swp 26 | *.swo 27 | *~ 28 | 29 | # other 30 | dist 31 | -------------------------------------------------------------------------------- /.github/security.md: -------------------------------------------------------------------------------- 1 | # Security Policy 2 | 3 | ## Supported Versions 4 | 5 | As with most R packages, only the latest package version is supported with bug 6 | fixes, features, etc. This also applies to security updates. 7 | 8 | ## Reporting a Vulnerability 9 | 10 | To report a security vulnerability, please use the 11 | [Tidelift security contact](https://tidelift.com/security). 12 | Tidelift will coordinate the fix and disclosure. 13 | 14 | -------------------------------------------------------------------------------- /examples/funcall.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | f0 <- function() NULL 4 | 5 | f1 <- function(a) NULL 6 | 7 | f2 <- function(a, b) NULL 8 | 9 | f3 <- function(a, b, c) NULL 10 | 11 | f10 <- function(a, b, c, d, e, f, g, h, i, j) NULL 12 | 13 | n <- 10000L 14 | 15 | res <- microbenchmark(f0(), f1(1), f2(1, 1), f3(1, 1, 1), 16 | f10(1, 1, 1, 1, 1, 1, 1, 1, 1, 1), 17 | times=n) 18 | print(res, unit="relative") 19 | -------------------------------------------------------------------------------- /examples/simple_lm.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | library("MASS") 3 | 4 | ctl <- c(4.17,5.58,5.18,6.11,4.50,4.61,5.17,4.53,5.33,5.14) 5 | trt <- c(4.81,4.17,4.41,3.59,5.87,3.83,6.03,4.89,4.32,4.69) 6 | group <- gl(2,10,20, labels=c("Ctl","Trt")) 7 | weight <- c(ctl, trt) 8 | 9 | res <- microbenchmark(lm(weight ~ group), 10 | rlm(weight ~ group), 11 | lqs(weight ~ group), 12 | times=300L) 13 | print(res) 14 | -------------------------------------------------------------------------------- /src/do_nothing.c: -------------------------------------------------------------------------------- 1 | #include "do_nothing.h" 2 | 3 | /* Do nothing but do it well. 4 | * 5 | * The purpose of this function is to have a callsite outside of the 6 | * nanotimer.c compilation unit which forces the compiler to emit a 7 | * call instruction instead of optimizing out the meaningless call. We 8 | * want the compiler to include the call to include the overhead in our 9 | * overhead estimation. 10 | */ 11 | int do_nothing(void) { 12 | return 42; 13 | } 14 | -------------------------------------------------------------------------------- /R/nanotime.R: -------------------------------------------------------------------------------- 1 | #' Return the current value of the platform timer. 2 | #' 3 | #' The current value of the most accurate timer of the platform is 4 | #' returned. This can be used as a time stamp for logging or similar 5 | #' purposes. Please note that there is no common reference, that is, 6 | #' the timer value cannot be converted to a date and time value. 7 | #' 8 | #' @author Olaf Mersmann 9 | get_nanotime <- function() { 10 | .Call(do_get_nanotime, PACKAGE="microbenchmark") 11 | } 12 | -------------------------------------------------------------------------------- /examples/relative.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | 3 | m <- microbenchmark(a=runif(100), b=runif(100), times=100L) 4 | 5 | relative <- function(x, order = TRUE) { 6 | sum <- summary(x) 7 | min <- sum[which.min(sum$median), , drop = FALSE] 8 | min$neval <- 1 # Ugly hack: Do not rescale neval 9 | sum[-1] <- sum[-1] / as.list(min[-1]) 10 | 11 | if (order) { 12 | sum <- sum[order(sum$median), , drop = FALSE] 13 | } 14 | 15 | sum 16 | } 17 | print(m) 18 | print(m, order="min") 19 | print(m, unit="relative") 20 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Run Travis CI for R using https://eddelbuettel.github.io/r-travis/ 2 | 3 | language: c 4 | 5 | sudo: required 6 | 7 | dist: trusty 8 | 9 | env: 10 | global: 11 | - _R_CHECK_FORCE_SUGGESTS_=false 12 | 13 | before_install: 14 | - curl -OLs https://eddelbuettel.github.io/r-travis/run.sh && chmod 0755 run.sh 15 | - ./run.sh bootstrap 16 | 17 | script: 18 | - ./run.sh run_tests 19 | 20 | after_failure: 21 | - ./run.sh dump_logs 22 | 23 | notifications: 24 | email: 25 | on_success: change 26 | on_failure: change 27 | 28 | -------------------------------------------------------------------------------- /man/get_nanotime.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/nanotime.R 3 | \name{get_nanotime} 4 | \alias{get_nanotime} 5 | \title{Return the current value of the platform timer.} 6 | \usage{ 7 | get_nanotime() 8 | } 9 | \description{ 10 | The current value of the most accurate timer of the platform is 11 | returned. This can be used as a time stamp for logging or similar 12 | purposes. Please note that there is no common reference, that is, 13 | the timer value cannot be converted to a date and time value. 14 | } 15 | \author{ 16 | Olaf Mersmann 17 | } 18 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # microbenchmark 2 | Infrastructure to accurately measure and compare the execution time of R expressions. 3 | 4 | ## Install from GitHub 5 | 6 | To install the bleeding edge version from GitHub run (requires the `remotes` package): 7 | 8 | ```r 9 | remotes::install_github("joshuaulrich/microbenchmark") 10 | ``` 11 | 12 | [![CRAN Status Badge](https://www.r-pkg.org/badges/version/microbenchmark)](https://cran.r-project.org/web/packages/microbenchmark) 13 | [![CRAN Downloads](https://cranlogs.r-pkg.org/badges/microbenchmark)](https://cran.rstudio.com/web/packages/microbenchmark/index.html) 14 | -------------------------------------------------------------------------------- /man/coalesce.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/internal.R 3 | \name{coalesce} 4 | \alias{coalesce} 5 | \title{Return first non null argument.} 6 | \usage{ 7 | coalesce(...) 8 | } 9 | \arguments{ 10 | \item{...}{List of values.} 11 | } 12 | \value{ 13 | First non null element in \code{...}. 14 | } 15 | \description{ 16 | This function is useful when processing complex arguments with multiple 17 | possible defaults based on other arguments that may or may not have been 18 | provided. 19 | } 20 | \author{ 21 | Olaf Mersmann 22 | } 23 | \keyword{internal} 24 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | S3method(boxplot,microbenchmark) 2 | S3method(print,microbenchmark) 3 | S3method(rbind,microbenchmark) 4 | S3method(summary,microbenchmark) 5 | 6 | if (getRversion() >= "3.6.0") { 7 | S3method(ggplot2::autoplot, microbenchmark) 8 | } 9 | 10 | export(get_nanotime) 11 | export(microbenchmark) 12 | export(microtiming_precision) 13 | 14 | importFrom(graphics,boxplot) 15 | importFrom(stats,aggregate) 16 | importFrom(stats,fivenum) 17 | importFrom(stats,lm) 18 | 19 | useDynLib(microbenchmark,do_get_nanotime) 20 | useDynLib(microbenchmark,do_microtiming) 21 | useDynLib(microbenchmark,do_microtiming_precision) 22 | -------------------------------------------------------------------------------- /tools/set-version: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 3 | get_version_from_git <- function() { 4 | tag <- system2("git", c("describe", "--tags", "--match", "v*"), 5 | stdout=TRUE, stderr=TRUE) 6 | is_clean <- system2("git", c("diff-index", "--quiet", tag)) == 0 7 | tt <- sub("v", "", tag, fixed=TRUE) 8 | tt <- paste(strsplit(tt, "-")[[1]][1:2], collapse="-") 9 | if (!is_clean) 10 | tt <- sub("-.*", sprintf("-%i", as.integer(Sys.time())), tt) 11 | tt 12 | } 13 | 14 | desc <- read.dcf("pkg/DESCRIPTION") 15 | desc[,"Version"] <- get_version_from_git() 16 | write.dcf(desc, file="pkg/DESCRIPTION") 17 | -------------------------------------------------------------------------------- /examples/types.R: -------------------------------------------------------------------------------- 1 | require("microbenchmark") 2 | 3 | zeromatrix <- function(nrow, ncol) { 4 | x <- numeric(nrow * ncol) 5 | dim(x) <- c(nrow, ncol) 6 | x 7 | } 8 | 9 | 10 | n <- 1000 11 | res1 <- microbenchmark(matrix(numeric(n*n), nrow=n, ncol=n), 12 | matrix(0, nrow=n, ncol=n), 13 | zeromatrix(n, n), 14 | times=100L) 15 | ## print(res) 16 | to_matrix <- function(x, nrow, ncol) { 17 | dim(x) <- c(nrow, ncol) 18 | x 19 | } 20 | 21 | x <- runif(n*n) 22 | res2 <- microbenchmark(matrix(x, nrow=n, ncol=n), 23 | to_matrix(x, n, n), 24 | times=100L) 25 | print(res2) 26 | 27 | -------------------------------------------------------------------------------- /src/nanotimer_rtposix.h: -------------------------------------------------------------------------------- 1 | /* 2 | * Solaris does not define gethrtime if _POSIX_C_SOURCE is defined because 3 | * gethrtime() is an extension to the POSIX.1.2001 standard. According to [1] 4 | * we need to define __EXTENSIONS__ before including sys/time.h in order to 5 | * force the declaration of non-standard functions. 6 | * 7 | * [1] http://www.oracle.com/technetwork/articles/servers-storage-dev/standardheaderfiles-453865.html 8 | */ 9 | #if defined(sun) || defined(__sun) 10 | #define __EXTENSIONS__ 11 | #endif 12 | 13 | # include 14 | 15 | /* short an sweet! */ 16 | static nanotime_t get_nanotime(void) { 17 | hrtime_t hrtime = gethrtime(); 18 | return (nanotime_t)hrtime; 19 | } 20 | -------------------------------------------------------------------------------- /src/nanotimer_clock_gettime.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | static const nanotime_t nanoseconds_in_second = 1000000000LL; 4 | 5 | static nanotime_t get_nanotime(void) { 6 | struct timespec time_var; 7 | 8 | /* Possible other values we could have used are CLOCK_MONOTONIC, 9 | * which is takes longer to retrieve and CLOCK_PROCESS_CPUTIME_ID 10 | * which, if I understand it correctly, would require the R 11 | * process to be bound to one core. 12 | */ 13 | clock_gettime(MB_CLOCKID_T, &time_var); 14 | 15 | nanotime_t sec = time_var.tv_sec; 16 | nanotime_t nsec = time_var.tv_nsec; 17 | 18 | /* Combine both values to one nanoseconds value */ 19 | return (nanoseconds_in_second * sec) + nsec; 20 | } 21 | -------------------------------------------------------------------------------- /src/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include // for NULL 4 | #include 5 | 6 | /* .Call calls */ 7 | extern SEXP do_get_nanotime(void); 8 | extern SEXP do_microtiming(SEXP, SEXP, SEXP, SEXP); 9 | extern SEXP do_microtiming_precision(SEXP, SEXP, SEXP); 10 | 11 | static const R_CallMethodDef CallEntries[] = { 12 | {"do_get_nanotime", (DL_FUNC) &do_get_nanotime, 0}, 13 | {"do_microtiming", (DL_FUNC) &do_microtiming, 4}, 14 | {"do_microtiming_precision", (DL_FUNC) &do_microtiming_precision, 3}, 15 | {NULL, NULL, 0} 16 | }; 17 | 18 | void R_init_microbenchmark(DllInfo *dll) 19 | { 20 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 21 | R_useDynamicSymbols(dll, FALSE); 22 | } 23 | -------------------------------------------------------------------------------- /R/microtiming_precision.R: -------------------------------------------------------------------------------- 1 | #' Estimate precision of timing routines. 2 | #' 3 | #' This function is currently experimental. Its main use is to judge 4 | #' the quality of the underlying timer implementation of the 5 | #' operating system. The function measures the overhead of timing a C 6 | #' function call \code{rounds} times and returns all non-zero timings 7 | #' observed. This can be used to judge the granularity and resolution 8 | #' of the timing subsystem. 9 | #' 10 | #' @param rounds Number of measurements used to estimate the precision. 11 | #' @param warmup Number of iterations used to warm up the CPU. 12 | #' @return A vector of observed non-zero timings. 13 | #' 14 | #' @author Olaf Mersmann 15 | microtiming_precision <- function(rounds=100L, warmup=2^18) { 16 | .Call(do_microtiming_precision, parent.frame(), 17 | as.integer(rounds), 18 | as.integer(warmup), 19 | PACKAGE="microbenchmark") 20 | } 21 | -------------------------------------------------------------------------------- /man/boxplot.microbenchmark.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/boxplot.R 3 | \name{boxplot.microbenchmark} 4 | \alias{boxplot.microbenchmark} 5 | \title{Boxplot of \code{microbenchmark} timings.} 6 | \usage{ 7 | \method{boxplot}{microbenchmark}( 8 | x, 9 | unit = "t", 10 | log = TRUE, 11 | xlab, 12 | ylab, 13 | horizontal = FALSE, 14 | main = "microbenchmark timings", 15 | ... 16 | ) 17 | } 18 | \arguments{ 19 | \item{x}{A \code{microbenchmark} object.} 20 | 21 | \item{unit}{Unit in which the results be plotted.} 22 | 23 | \item{log}{Should times be plotted on log scale?} 24 | 25 | \item{xlab}{X axis label.} 26 | 27 | \item{ylab}{Y axis label.} 28 | 29 | \item{horizontal}{Switch X and Y axes.} 30 | 31 | \item{main}{Plot title.} 32 | 33 | \item{...}{Passed on to boxplot.formula.} 34 | } 35 | \description{ 36 | Boxplot of \code{microbenchmark} timings. 37 | } 38 | \author{ 39 | Olaf Mersmann 40 | } 41 | -------------------------------------------------------------------------------- /man/microtiming_precision.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/microtiming_precision.R 3 | \name{microtiming_precision} 4 | \alias{microtiming_precision} 5 | \title{Estimate precision of timing routines.} 6 | \usage{ 7 | microtiming_precision(rounds = 100L, warmup = 2^18) 8 | } 9 | \arguments{ 10 | \item{rounds}{Number of measurements used to estimate the precision.} 11 | 12 | \item{warmup}{Number of iterations used to warm up the CPU.} 13 | } 14 | \value{ 15 | A vector of observed non-zero timings. 16 | } 17 | \description{ 18 | This function is currently experimental. Its main use is to judge 19 | the quality of the underlying timer implementation of the 20 | operating system. The function measures the overhead of timing a C 21 | function call \code{rounds} times and returns all non-zero timings 22 | observed. This can be used to judge the granularity and resolution 23 | of the timing subsystem. 24 | } 25 | \author{ 26 | Olaf Mersmann 27 | } 28 | -------------------------------------------------------------------------------- /man/find_prefix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/internal.R 3 | \name{find_prefix} 4 | \alias{find_prefix} 5 | \title{Find SI prefix for unit} 6 | \usage{ 7 | find_prefix(x, f = min, minexp = -Inf, maxexp = Inf, mu = TRUE) 8 | } 9 | \arguments{ 10 | \item{x}{a numeric} 11 | 12 | \item{f}{function that produces the number from \code{x} that is used to 13 | determine the prefix, e.g. \code{\link[base]{min}} or 14 | \code{\link[stats]{median}}.} 15 | 16 | \item{minexp}{minimum (decimal) exponent to consider, 17 | e.g. -3 to suppress prefixes smaller than milli (m).} 18 | 19 | \item{maxexp}{maximum (decimal) exponent to consider, 20 | e.g. 3 to suppress prefixes larger than kilo (k).} 21 | 22 | \item{mu}{if \code{TRUE}, should a proper mu be used for micro, otherwise use 23 | u as ASCII-compatible replacement} 24 | } 25 | \value{ 26 | character with the SI prefix 27 | } 28 | \description{ 29 | Find SI prefix for unit 30 | } 31 | \author{ 32 | Claudia Beleites 33 | } 34 | \keyword{internal} 35 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: microbenchmark 2 | Title: Accurate Timing Functions 3 | Description: Provides infrastructure to accurately measure and compare 4 | the execution time of R expressions. 5 | Authors@R: c(person("Olaf", "Mersmann", role=c("aut")), 6 | person("Claudia", "Beleites", role=c("ctb")), 7 | person("Rainer", "Hurling", role=c("ctb")), 8 | person("Ari", "Friedman", role=c("ctb")), 9 | person(given=c("Joshua","M."), family="Ulrich", role="cre", 10 | email="josh.m.ulrich@gmail.com")) 11 | URL: https://github.com/joshuaulrich/microbenchmark/ 12 | BugReports: https://github.com/joshuaulrich/microbenchmark/issues/ 13 | License: BSD_2_clause + file LICENSE 14 | Depends: R (>= 3.2.0) 15 | Imports: graphics, stats 16 | Suggests: ggplot2, multcomp, RUnit 17 | SystemRequirements: On a Unix-alike, one of the C functions mach_absolute_time (macOS), clock_gettime or gethrtime. If none of these is found, the obsolescent POSIX function gettimeofday will be tried. 18 | ByteCompile: yes 19 | Version: 1.5.0 20 | -------------------------------------------------------------------------------- /R/rbind.R: -------------------------------------------------------------------------------- 1 | #' @method rbind microbenchmark 2 | rbind.microbenchmark <- 3 | function(..., deparse.level = 1) 4 | { 5 | args <- list(...) 6 | is_mb <- sapply(args, inherits, "microbenchmark") 7 | if(!all(is_mb)) { 8 | stop("can only combine microbenchmark objects") 9 | } 10 | 11 | output <- args 12 | arg_names <- as.character(substitute(alist(...))[-1]) 13 | all_levels <- NULL 14 | for(i in seq_along(output)) { 15 | # expressions and levels for object 'i' 16 | i_expr <- output[[i]]$expr 17 | i_levels <- levels(i_expr) 18 | # all levels so far... 19 | all_levels <- c(all_levels, i_levels) 20 | # add object name to suffix for duplicated expressions 21 | has_dups <- utils::tail(duplicated(all_levels), -nlevels(i_expr)) 22 | if (any(has_dups)) { 23 | levels(output[[i]]$expr) <- paste(i_levels, arg_names[i], sep = ".") 24 | } 25 | } 26 | output <- do.call("rbind.data.frame", output) 27 | class(output) <- class(args[[1]]) 28 | return(output) 29 | } 30 | -------------------------------------------------------------------------------- /R/zzz.R: -------------------------------------------------------------------------------- 1 | register_s3_method <- 2 | function(pkg, generic, class, fun = NULL) 3 | { 4 | stopifnot(is.character(pkg), length(pkg) == 1L) 5 | stopifnot(is.character(generic), length(generic) == 1L) 6 | stopifnot(is.character(class), length(class) == 1L) 7 | 8 | if (is.null(fun)) { 9 | fun <- get(paste0(generic, ".", class), envir = parent.frame()) 10 | } else { 11 | stopifnot(is.function(fun)) 12 | } 13 | 14 | if (isNamespaceLoaded(pkg)) { 15 | registerS3method(generic, class, fun, envir = asNamespace(pkg)) 16 | } 17 | 18 | # Always register hook in case package is later unloaded & reloaded 19 | setHook( 20 | packageEvent(pkg, "onLoad"), 21 | function(...) { 22 | registerS3method(generic, class, fun, envir = asNamespace(pkg)) 23 | } 24 | ) 25 | } 26 | 27 | .onLoad <- function(libname, pkgname) { 28 | if (getRversion() < "3.6.0") { 29 | register_s3_method("ggplot2", "autoplot", "microbenchmark") 30 | } 31 | invisible() 32 | } 33 | 34 | .onUnload <- function(libpath) { 35 | library.dynam.unload("microbenchmark", libpath) 36 | } 37 | -------------------------------------------------------------------------------- /src/nanotimer_macosx.h: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* QA1398 [1] warns that this calculation may overflow uint64: 4 | * mach_absolute_time() * mach_timebase_info.numer / mach_timebase_info.denom 5 | * 6 | * The StackOverflow question [2] suggests that it's mainly a problem on 7 | * Power-PC Macs, since the numerator and denominator are both 1 on Intel 8 | * Macs. 9 | * 10 | * [1] https://developer.apple.com/library/content/qa/qa1398/_index.html 11 | * [2] https://stackoverflow.com/questions/23378063 12 | */ 13 | static nanotime_t get_nanotime(void) { 14 | static uint64_t ratio = 0; 15 | if (ratio == 0) { 16 | mach_timebase_info_data_t info; 17 | mach_timebase_info(&info); 18 | if ((info.numer % info.denom) == 0) { 19 | ratio = info.numer / info.denom; 20 | } else { 21 | warning("less accurate nanosecond times to avoid potential integer overflows"); 22 | ratio = (uint64_t)((double)info.numer / info.denom); 23 | } 24 | } 25 | 26 | uint64_t time = mach_absolute_time(); 27 | 28 | /* Convert to nanoseconds */ 29 | return (nanotime_t)(time * ratio); 30 | } 31 | -------------------------------------------------------------------------------- /man/convert_to_unit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/internal.R 3 | \name{convert_to_unit} 4 | \alias{convert_to_unit} 5 | \title{Convert timings to different units.} 6 | \usage{ 7 | convert_to_unit(object, unit) 8 | } 9 | \arguments{ 10 | \item{object}{A \code{microbenchmark} object.} 11 | 12 | \item{unit}{A unit of time. See details.} 13 | } 14 | \value{ 15 | A matrix containing the converted time values with an 16 | attribute \code{unit} which is a printable name of the unit of 17 | time. 18 | } 19 | \description{ 20 | The following units of time are supported \describe{ 21 | \item{\dQuote{ns}}{Nanoseconds.} 22 | \item{\dQuote{us}}{Microseconds.} 23 | \item{\dQuote{ms}}{Milliseconds.} 24 | \item{\dQuote{s}}{Seconds.} 25 | \item{\dQuote{t}}{Appropriately prefixed time unit.} 26 | \item{\dQuote{hz}}{Hertz / evaluations per second.} 27 | \item{\dQuote{eps}}{Evaluations per second / Hertz.} 28 | \item{\dQuote{khz}}{Kilohertz / 1000s of evaluations per second.} 29 | \item{\dQuote{mhz}}{Megahertz / 1000000s of evaluations per second.} 30 | \item{\dQuote{f}}{Appropriately prefixed frequency unit.} 31 | } 32 | } 33 | \author{ 34 | Olaf Mersmann 35 | } 36 | \keyword{internal} 37 | -------------------------------------------------------------------------------- /man/summary.microbenchmark.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/summary.R 3 | \name{summary.microbenchmark} 4 | \alias{summary.microbenchmark} 5 | \title{Summarize \code{microbenchmark} timings.} 6 | \usage{ 7 | \method{summary}{microbenchmark}(object, unit, ..., include_cld = TRUE) 8 | } 9 | \arguments{ 10 | \item{object}{An object of class \code{microbenchmark}.} 11 | 12 | \item{unit}{What unit to print the timings in. If none is given, 13 | either the \code{unit} attribute of \code{object} or the option 14 | \code{microbenchmark.unit} is used and if neither is set 15 | \dQuote{t} is used.} 16 | 17 | \item{...}{Ignored} 18 | 19 | \item{include_cld}{Calculate \code{cld} using \code{multcomp::glht()} 20 | and add it to the output. Set to \code{FALSE} if the calculation takes 21 | too long.} 22 | } 23 | \value{ 24 | A \code{data.frame} containing the aggregated results. 25 | } 26 | \description{ 27 | Summarize \code{microbenchmark} timings. 28 | } 29 | \note{ 30 | The available units are nanoseconds (\code{"ns"}), 31 | microseconds (\code{"us"}), milliseconds (\code{"ms"}), seconds 32 | (\code{"s"}) and evaluations per seconds (\code{"eps"}) and 33 | relative runtime compared to the best median time 34 | (\code{"relative"}). 35 | } 36 | \seealso{ 37 | \code{\link{print.microbenchmark}} 38 | } 39 | -------------------------------------------------------------------------------- /man/determine_unit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/internal.R 3 | \name{determine_unit} 4 | \alias{determine_unit} 5 | \title{Normalize timing units to one of the supported values} 6 | \usage{ 7 | determine_unit(object = NULL, unit = NULL) 8 | } 9 | \arguments{ 10 | \item{object}{A 'microbenchmark' object.} 11 | 12 | \item{unit}{A unit of time. See details.} 13 | } 14 | \value{ 15 | A matrix containing the converted time values with an 16 | attribute \code{unit} which is a printable name of the unit of 17 | time. 18 | } 19 | \description{ 20 | We support the following units of time 21 | \describe{ 22 | \item{\dQuote{ns}, \dQuote{nanoseconds}}{} 23 | \item{\dQuote{us}, \dQuote{microseconds}}{} 24 | \item{\dQuote{ms}, \dQuote{milliseconds}}{} 25 | \item{\dQuote{s}, \dQuote{secs}, \dQuote{seconds}}{} 26 | \item{\dQuote{t}, \dQuote{time}}{Appropriately prefixed time unit.} 27 | \item{\dQuote{eps}}{Evaluations per second / Hertz.} 28 | \item{\dQuote{hz}}{Hertz / evaluations per second.} 29 | \item{\dQuote{khz}}{Kilohertz / 1000s of evaluations per second.} 30 | \item{\dQuote{mhz}}{Megahertz / 1000000s of evaluations per second.} 31 | \item{\dQuote{f}, \dQuote{frequency}}{Appropriately prefixed frequency unit.} 32 | } 33 | } 34 | \author{ 35 | Joshua M. Ulrich 36 | } 37 | \keyword{internal} 38 | -------------------------------------------------------------------------------- /man/autoplot.microbenchmark.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/autoplot.R 3 | \name{autoplot.microbenchmark} 4 | \alias{autoplot.microbenchmark} 5 | \title{Autoplot method for microbenchmark objects: Prettier graphs for 6 | microbenchmark using ggplot2} 7 | \usage{ 8 | autoplot.microbenchmark( 9 | object, 10 | ..., 11 | order = NULL, 12 | log = TRUE, 13 | unit = NULL, 14 | y_max = NULL 15 | ) 16 | } 17 | \arguments{ 18 | \item{object}{A microbenchmark object.} 19 | 20 | \item{\dots}{Ignored.} 21 | 22 | \item{order}{Names of output column(s) to order the results.} 23 | 24 | \item{log}{If \code{TRUE} the time axis will be on log scale.} 25 | 26 | \item{unit}{The unit to use for graph labels.} 27 | 28 | \item{y_max}{The upper limit of the y axis, in the unit automatically 29 | chosen for the time axis (defaults to the maximum value).} 30 | } 31 | \value{ 32 | A ggplot2 object. 33 | } 34 | \description{ 35 | Uses ggplot2 to produce a more legible graph of microbenchmark timings. 36 | } 37 | \examples{ 38 | if (requireNamespace("ggplot2", quietly = TRUE)) { 39 | tm <- microbenchmark(rchisq(100, 0), 40 | rchisq(100, 1), 41 | rchisq(100, 2), 42 | rchisq(100, 3), 43 | rchisq(100, 5), times=1000L) 44 | ggplot2::autoplot(tm) 45 | 46 | # add a custom title 47 | ggplot2::autoplot(tm) + ggplot2::ggtitle("my timings") 48 | } 49 | } 50 | \author{ 51 | Ari Friedman, Olaf Mersmann 52 | } 53 | -------------------------------------------------------------------------------- /examples/dispatchspeed.R: -------------------------------------------------------------------------------- 1 | library("methods") 2 | library("proto") 3 | library("microbenchmark") 4 | 5 | messagef <- function(msg, ...) 6 | message(sprintf(msg, ...)) 7 | 8 | ## Plain old R style function call: 9 | plain_object <- function() 10 | list(a=1, b="bam") 11 | 12 | plain_fun <- function(x, ...) 13 | NULL 14 | 15 | ## S3 style method call: 16 | s3_object <- function() 17 | structure(list(a=1, b="bam"), 18 | class="s3_object") 19 | 20 | s3_fun <- function(x, ...) 21 | UseMethod("s3_fun") 22 | 23 | s3_fun.s3_object <- function(x, ...) 24 | NULL 25 | 26 | ## S4 style method call: 27 | setClass("s4_object", representation(a="numeric", b="character")) 28 | 29 | s4_object <- function() 30 | new("s4_object", a=1, b="bam") 31 | 32 | setGeneric("s4_fun", function(x, ...) standardGeneric("s4_fun")) 33 | 34 | setMethod("s4_fun", "s4_object", function(x, ...) NULL) 35 | for (i in 1:200) { 36 | n <- sprintf("a4_object_%i", i) 37 | setClass(n, representation(a="numeric", b="character")) 38 | setMethod("s4_fun", n, function(x, ...) NULL) 39 | } 40 | 41 | ## Proto style methods call: 42 | proto_object <- proto(expr={ 43 | a <- 1 44 | b <- "bam" 45 | proto_fun <- function(., ...) NULL 46 | }) 47 | 48 | ## Micro benchmark of call speed: 49 | n <- 1000L 50 | op <- plain_object() 51 | o3 <- s3_object() 52 | o4 <- s4_object() 53 | po <- proto_object$proto() 54 | ppo <- proto_object$proto({ 55 | roto_fun <- function(., ...) NULL 56 | }) 57 | 58 | pppo <- proto_object$proto()$proto()$proto()$proto()$proto() 59 | 60 | speed <- microbenchmark(plain_fun(op), s3_fun(o3), 61 | s4_fun(o4), 62 | po$proto_fun(), ppo$proto_fun(), pppo$proto_fun(), 63 | times=n) 64 | print(speed, unit="eps") 65 | -------------------------------------------------------------------------------- /examples/multcomp.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | library("multcomp") 3 | 4 | ssqdif <- function(X, Y=X) { 5 | #From 'outer' without modification 6 | Y <- rep(Y, rep.int(length(X), length(Y))) 7 | X <- rep(X, times = ceiling(length(Y)/length(X))) 8 | #For this case: 9 | sum((X-Y)^2) #SLIGHTLY quicker than d<-X-Y; sum(d*d) 10 | } 11 | 12 | outerdif <- function(X, Y = X) { 13 | gg <- outer(X, Y, FUN="-") 14 | sum(gg*gg) 15 | } 16 | 17 | X <- runif(1000) 18 | m <- microbenchmark( 19 | ssqdif(X), 20 | outerdif(X) 21 | ) 22 | 23 | library(multcomp) 24 | mod <- lm(time ~ expr, m) 25 | comp <- glht(mod, mcp(expr = "Tukey")) 26 | cld(comp) 27 | sm <- summary(m) 28 | sm$ratio <- sm$median / min(sm$median) 29 | sm$cld <- cld(comp)$mcletters$monospacedLetters 30 | -------------------------------------------------------------------------------- /man/print.microbenchmark.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/print.R 3 | \name{print.microbenchmark} 4 | \alias{print.microbenchmark} 5 | \title{Print \code{microbenchmark} timings.} 6 | \usage{ 7 | \method{print}{microbenchmark}(x, unit, order, signif, ...) 8 | } 9 | \arguments{ 10 | \item{x}{An object of class \code{microbenchmark}.} 11 | 12 | \item{unit}{What unit to print the timings in. Default value taken 13 | from to option \code{microbenchmark.unit} (see example).} 14 | 15 | \item{order}{If present, order results according to this column of the output.} 16 | 17 | \item{signif}{If present, limit the number of significant digits shown.} 18 | 19 | \item{...}{Passed to \code{print.data.frame}} 20 | } 21 | \description{ 22 | Print \code{microbenchmark} timings. 23 | } 24 | \note{ 25 | The available units are nanoseconds (\code{"ns"}), microseconds 26 | (\code{"us"}), milliseconds (\code{"ms"}), seconds (\code{"s"}) 27 | and evaluations per seconds (\code{"eps"}) and relative runtime 28 | compared to the best median time (\code{"relative"}). 29 | 30 | If the \code{multcomp} package is available a statistical 31 | ranking is calculated and displayed in compact letter display from 32 | in the \code{cld} column. 33 | } 34 | \examples{ 35 | a1 <- a2 <- a3 <- a4 <- numeric(0) 36 | 37 | res <- microbenchmark(a1 <- c(a1, 1), 38 | a2 <- append(a2, 1), 39 | a3[length(a3) + 1] <- 1, 40 | a4[[length(a4) + 1]] <- 1, 41 | times=100L) 42 | print(res) 43 | ## Change default unit to relative runtime 44 | options(microbenchmark.unit="relative") 45 | print(res) 46 | ## Change default unit to evaluations per second 47 | options(microbenchmark.unit="eps") 48 | print(res) 49 | 50 | } 51 | \seealso{ 52 | \code{\link{boxplot.microbenchmark}} and 53 | \code{\link{autoplot.microbenchmark}} for a plot methods. 54 | } 55 | \author{ 56 | Olaf Mersmann 57 | } 58 | -------------------------------------------------------------------------------- /R/boxplot.R: -------------------------------------------------------------------------------- 1 | #' Boxplot of \code{microbenchmark} timings. 2 | #' 3 | #' @param x A \code{microbenchmark} object. 4 | #' @param unit Unit in which the results be plotted. 5 | #' @param log Should times be plotted on log scale? 6 | #' @param xlab X axis label. 7 | #' @param ylab Y axis label. 8 | #' @param horizontal Switch X and Y axes. 9 | #' @param main Plot title. 10 | #' @param ... Passed on to boxplot.formula. 11 | #' 12 | #' @method boxplot microbenchmark 13 | #' 14 | #' @author Olaf Mersmann 15 | boxplot.microbenchmark <- function(x, unit="t", log=TRUE, xlab, ylab, 16 | horizontal=FALSE, main="microbenchmark timings", ...) { 17 | x$time <- convert_to_unit(x, unit) 18 | timeunits <- c("ns", "us", "ms", "s", "t") 19 | frequnits <- c("hz", "khz", "mhz", "eps", "f") 20 | 21 | if (missing(xlab)) 22 | xlab <- "Expression" 23 | if (missing(ylab)) { 24 | ylab <- if (log) { 25 | if (unit %in% timeunits) 26 | paste("log(time) [", unit, "]", sep="") 27 | else if (unit %in% frequnits) 28 | paste("log(frequency) [", unit, "]", sep="") 29 | else 30 | paste("log(", unit, ")", sep="") 31 | } else { 32 | if (unit %in% timeunits) 33 | paste("time [", unit, "]", sep="") 34 | else if (unit %in% frequnits) 35 | paste("frequency [", unit, "]", sep="") 36 | else if (unit == "eps") 37 | "evaluations per second [Hz]" 38 | else 39 | unit 40 | } 41 | } 42 | 43 | if (log) { 44 | # min time cannot be 0 for log y-axis 45 | ylim <- pmax(1, range(x$time)) 46 | } else { 47 | ylim <- NULL 48 | } 49 | if (horizontal) { 50 | ll <- if (log) "x" else "" 51 | boxplot(time ~ expr, data=x, xlab=ylab, ylab=xlab, log=ll, ylim=ylim, 52 | horizontal=TRUE, main=main, ...) 53 | } else { 54 | ll <- if (log) "y" else "" 55 | boxplot(time ~ expr, data=x, xlab=xlab, ylab=ylab, log=ll, ylim=ylim, main=main, ...) 56 | } 57 | } 58 | -------------------------------------------------------------------------------- /src/sexp_macros.h: -------------------------------------------------------------------------------- 1 | /* 2 | * sexp_macros.h - helper macros for SEXPs 3 | * 4 | * Collection of useful macros to handle S expressions. Most of these 5 | * are used to unpack arguments passed in via the .Call() or 6 | * .External() interface. 7 | * 8 | * Author: 9 | * Olaf Mersmann (OME) 10 | */ 11 | 12 | #if !defined(__SEXP_MACROS_H__) 13 | #define __SEXP_MACROS_H__ 14 | 15 | #include 16 | #include 17 | 18 | #define CHECK_ARG_IS_REAL_MATRIX(A) \ 19 | if (!isReal(A) || !isMatrix(A)) \ 20 | error("Argument '" #A "' is not a real matrix."); 21 | 22 | #define CHECK_ARG_IS_REAL_VECTOR(A) \ 23 | if (!isReal(A) || !isVector(A)) \ 24 | error("Argument '" #A "' is not a real vector."); 25 | 26 | #define CHECK_ARG_IS_INT_VECTOR(A) \ 27 | if (!isInteger(A) || !isVector(A)) \ 28 | error("Argument '" #A "' is not an integer vector."); 29 | 30 | /* 31 | * Unpack a real matrix stored in SEXP S. 32 | */ 33 | #define UNPACK_REAL_MATRIX(S, D, N, K) \ 34 | CHECK_ARG_IS_REAL_MATRIX(S); \ 35 | double *D = REAL(S); \ 36 | const R_len_t N = nrows(S); \ 37 | const R_len_t K = ncols(S); 38 | 39 | /* 40 | * Unpack a real vector stored in SEXP S. 41 | */ 42 | #define UNPACK_REAL_VECTOR(S, D, N) \ 43 | CHECK_ARG_IS_REAL_VECTOR(S); \ 44 | double *D = REAL(S); \ 45 | const R_len_t N = length(S); 46 | 47 | /* 48 | * Unpack a single real stored in SEXP S. 49 | */ 50 | #define UNPACK_REAL(S, D) \ 51 | CHECK_ARG_IS_REAL_VECTOR(S); \ 52 | double D = REAL(S)[0]; \ 53 | 54 | /* 55 | * Unpack an integer vector stored in SEXP S. 56 | */ 57 | #define UNPACK_INT_VECTOR(S, I, N) \ 58 | CHECK_ARG_IS_INT_VECTOR(S); \ 59 | int *I = INTEGER(S); \ 60 | const R_len_t N = length(S); 61 | 62 | /* 63 | * Unpack a single integer stored in SEXP S. 64 | */ 65 | #define UNPACK_INT(S, I) \ 66 | CHECK_ARG_IS_INT_VECTOR(S); \ 67 | int I = INTEGER(S)[0]; \ 68 | 69 | #endif 70 | -------------------------------------------------------------------------------- /R/print.R: -------------------------------------------------------------------------------- 1 | #' Print \code{microbenchmark} timings. 2 | #' 3 | #' @param x An object of class \code{microbenchmark}. 4 | #' @param unit What unit to print the timings in. Default value taken 5 | #' from to option \code{microbenchmark.unit} (see example). 6 | #' @param order If present, order results according to this column of the output. 7 | #' @param signif If present, limit the number of significant digits shown. 8 | #' @param ... Passed to \code{print.data.frame} 9 | #' 10 | #' @note The available units are nanoseconds (\code{"ns"}), microseconds 11 | #' (\code{"us"}), milliseconds (\code{"ms"}), seconds (\code{"s"}) 12 | #' and evaluations per seconds (\code{"eps"}) and relative runtime 13 | #' compared to the best median time (\code{"relative"}). 14 | #' 15 | #' @note If the \code{multcomp} package is available a statistical 16 | #' ranking is calculated and displayed in compact letter display from 17 | #' in the \code{cld} column. 18 | #' 19 | #' @seealso \code{\link{boxplot.microbenchmark}} and 20 | #' \code{\link{autoplot.microbenchmark}} for a plot methods. 21 | #' 22 | #' @examples 23 | #' a1 <- a2 <- a3 <- a4 <- numeric(0) 24 | #' 25 | #' res <- microbenchmark(a1 <- c(a1, 1), 26 | #' a2 <- append(a2, 1), 27 | #' a3[length(a3) + 1] <- 1, 28 | #' a4[[length(a4) + 1]] <- 1, 29 | #' times=100L) 30 | #' print(res) 31 | #' ## Change default unit to relative runtime 32 | #' options(microbenchmark.unit="relative") 33 | #' print(res) 34 | #' ## Change default unit to evaluations per second 35 | #' options(microbenchmark.unit="eps") 36 | #' print(res) 37 | #' 38 | #' @method print microbenchmark 39 | #' @author Olaf Mersmann 40 | print.microbenchmark <- function(x, unit, order, signif, ...) { 41 | if (missing(unit)) { 42 | unit <- NULL 43 | } 44 | unit <- determine_unit(x, unit) 45 | s <- summary(x, unit=unit) 46 | timing_cols <- c("min", "lq", "median", "uq", "max", "mean") 47 | if (!missing(signif)) { 48 | s[timing_cols] <- lapply(s[timing_cols], base::signif, signif) 49 | } 50 | cat("Unit: ", attr(s, "unit"), "\n", sep="") 51 | if (!missing(order)) { 52 | if (order %in% colnames(s)) { 53 | s <- s[order(s[[order]]), ] 54 | } else { 55 | warning("Cannot order results by", order, ".") 56 | } 57 | } 58 | print(s, ..., row.names=FALSE) 59 | invisible(x) 60 | } 61 | -------------------------------------------------------------------------------- /examples/stringdispatch.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | library("methods") 3 | 4 | ## Class definitions: 5 | setClass("s4_class", representation(id="character", num="numeric")) 6 | setClass("s4_subclass", contains="s4_class") 7 | setClass("s4_subsubclass", contains="s4_subclass") 8 | 9 | ## Constructors: 10 | s4_class <- function(id, num) new("s4_class", id=id, num=num) 11 | s4_subclass <- function(id, num) new("s4_subclass", id=id, num=num) 12 | s4_subsubclass <- function(id, num) new("s4_subsubclass", id=id, num=num) 13 | 14 | ## Getters: 15 | setMethod(f="[", signature = signature("s4_class"), 16 | def=function(x, i, j, ..., drop) { 17 | if (i %in% slotNames(x)) 18 | return (slot(x, i)) 19 | return (NULL) 20 | }) 21 | 22 | setMethod(f="[", signature = signature("s4_subclass"), 23 | def=function(x, i, j, ..., drop) { 24 | if (i == "bam") 25 | return ("ham") 26 | if (i == "ham") 27 | return ("bam") 28 | callNextMethod() 29 | }) 30 | 31 | setMethod(f="[", signature = signature("s4_subsubclass"), 32 | def=function(x, i, j, ..., drop) { 33 | if (i == "foo") 34 | return ("bar") 35 | if (i == "bar") 36 | return ("foo") 37 | callNextMethod() 38 | }) 39 | 40 | setGeneric(name="get_id", 41 | def=function(x) standardGeneric("get_id")) 42 | 43 | setMethod("get_id", "s4_class", function(x) x@id) 44 | 45 | 46 | setGeneric(name="getId", 47 | def=function(x) standardGeneric("getId")) 48 | 49 | setMethod("getId", "s4_class", function(x) x@id) 50 | setMethod("getId", "s4_subclass", function(x) callNextMethod()) 51 | setMethod("getId", "s4_subsubclass", function(x) callNextMethod()) 52 | 53 | ## Micro benchmark of call speed: 54 | n <- 100L 55 | c4 <- s4_class(id="foo", num=2) 56 | sc4 <- s4_subclass(id="foo", num=2) 57 | ssc4 <- s4_subsubclass(id="foo", num=2) 58 | 59 | speed <- microbenchmark(c4@id, sc4@id, ssc4@id, 60 | get_id(c4), get_id(sc4), get_id(ssc4), 61 | getId(c4), getId(sc4), getId(ssc4), 62 | c4["id"], sc4["id"], ssc4["id"], 63 | ## as(c4, "s4_class")["id"], as(sc4, "s4_class")["id"], as(ssc4, "s4_class")["id"], 64 | times=n) 65 | print(speed) 66 | print(speed, "eps") 67 | -------------------------------------------------------------------------------- /tests/doRUnit.R: -------------------------------------------------------------------------------- 1 | ## unit tests will not be done if RUnit is not available 2 | if(require("RUnit", quietly=TRUE)) { 3 | 4 | ## --- Setup --- 5 | R_CMD_CHECK <- Sys.getenv("RCMDCHECK") != "FALSE" 6 | 7 | pkg <- "microbenchmark" # <-- Change to package name! 8 | if (R_CMD_CHECK) { 9 | ## Path to unit tests for R CMD check 10 | ## PKG.Rcheck/tests/../PKG/unitTests 11 | path <- system.file(package=pkg, "unitTests") 12 | } else { 13 | ## Path to unit tests for standalone running under Makefile (not R CMD check) 14 | ## PKG/tests/../inst/unitTests 15 | path <- file.path(getwd(), "..", "inst", "unitTests") 16 | } 17 | cat("\nRunning unit tests\n") 18 | print(list(pkg=pkg, getwd=getwd(), pathToUnitTests=path)) 19 | 20 | library(package=pkg, character.only=TRUE) 21 | 22 | ## If desired, load the name space to allow testing of private functions 23 | ## if (is.element(pkg, loadedNamespaces())) 24 | ## attach(loadNamespace(pkg), name=paste("namespace", pkg, sep=":"), pos=3) 25 | ## 26 | ## or simply call PKG:::myPrivateFunction() in tests 27 | 28 | ## --- Testing --- 29 | 30 | ## Define tests 31 | testSuite <- defineTestSuite(name=paste(pkg, "unit testing"), 32 | dirs=path) 33 | ## Run 34 | tests <- runTestSuite(testSuite) 35 | 36 | ## Report to stdout 37 | cat("------------------- UNIT TEST SUMMARY ---------------------\n\n") 38 | printTextProtocol(tests, showDetails=FALSE) 39 | 40 | ## Report text files (only if not under R CMD check) 41 | if (!R_CMD_CHECK) { 42 | ## Default report name 43 | pathReport <- file.path(path, "report") 44 | 45 | printTextProtocol(tests, showDetails=FALSE, 46 | fileName=paste(pathReport, "Summary.txt", sep="")) 47 | printTextProtocol(tests, showDetails=TRUE, 48 | fileName=paste(pathReport, ".txt", sep="")) 49 | 50 | ## Report to HTML file 51 | printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep="")) 52 | } 53 | 54 | ## Return stop() to cause R CMD check stop in case of 55 | ## - failures i.e. FALSE to unit tests or 56 | ## - errors i.e. R errors 57 | tmp <- getErrors(tests) 58 | if(tmp$nFail > 0 | tmp$nErr > 0) { 59 | stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, 60 | ", #R errors: ", tmp$nErr, ")\n\n", sep="")) 61 | } 62 | } else { 63 | warning("cannot run unit tests -- package RUnit is not available") 64 | } 65 | -------------------------------------------------------------------------------- /src/config.h.in: -------------------------------------------------------------------------------- 1 | /* src/config.h.in. Generated from configure.ac by autoheader. */ 2 | 3 | /* Define to 1 if you have the header file. */ 4 | #undef HAVE_INTTYPES_H 5 | 6 | /* Define to 1 if you have the header file. */ 7 | #undef HAVE_STDINT_H 8 | 9 | /* Define to 1 if you have the header file. */ 10 | #undef HAVE_STDIO_H 11 | 12 | /* Define to 1 if you have the header file. */ 13 | #undef HAVE_STDLIB_H 14 | 15 | /* Define to 1 if you have the header file. */ 16 | #undef HAVE_STRINGS_H 17 | 18 | /* Define to 1 if you have the header file. */ 19 | #undef HAVE_STRING_H 20 | 21 | /* Define to 1 if you have the header file. */ 22 | #undef HAVE_SYS_STAT_H 23 | 24 | /* Define to 1 if you have the header file. */ 25 | #undef HAVE_SYS_TIME_H 26 | 27 | /* Define to 1 if you have the header file. */ 28 | #undef HAVE_SYS_TYPES_H 29 | 30 | /* Define to 1 if you have the header file. */ 31 | #undef HAVE_UNISTD_H 32 | 33 | /* clockid_t to use with clock_gettime */ 34 | #undef MB_CLOCKID_T 35 | 36 | /* Define to 1 if you have the `clock_gettime` function. */ 37 | #undef MB_HAVE_CLOCK_GETTIME 38 | 39 | /* Define to 1 if you have the `gethrtime` function. */ 40 | #undef MB_HAVE_GETHRTIME 41 | 42 | /* Define to 1 if you have the `gettimeofday` function. */ 43 | #undef MB_HAVE_GETTIMEOFDAY 44 | 45 | /* Define to 1 if you have the `mach_absolute_time` function. */ 46 | #undef MB_HAVE_MACH_TIME 47 | 48 | /* Define to the address where bug reports for this package should be sent. */ 49 | #undef PACKAGE_BUGREPORT 50 | 51 | /* Define to the full name of this package. */ 52 | #undef PACKAGE_NAME 53 | 54 | /* Define to the full name and version of this package. */ 55 | #undef PACKAGE_STRING 56 | 57 | /* Define to the one symbol short name of this package. */ 58 | #undef PACKAGE_TARNAME 59 | 60 | /* Define to the home page for this package. */ 61 | #undef PACKAGE_URL 62 | 63 | /* Define to the version of this package. */ 64 | #undef PACKAGE_VERSION 65 | 66 | /* Define to 1 if all of the C90 standard headers exist (not just the ones 67 | required in a freestanding environment). This macro is provided for 68 | backward compatibility; new code need not use it. */ 69 | #undef STDC_HEADERS 70 | 71 | /* Define for Solaris 2.5.1 so the uint64_t typedef from , 72 | , or is not used. If the typedef were allowed, the 73 | #define below would cause a syntax error. */ 74 | #undef _UINT64_T 75 | 76 | /* Enable FreeBSD-specific clockid */ 77 | #undef __BSD_VISIBLE 78 | 79 | /* Define to the type of an unsigned integer type of width exactly 64 bits if 80 | such a type exists and the standard includes do not define it. */ 81 | #undef uint64_t 82 | -------------------------------------------------------------------------------- /R/autoplot.R: -------------------------------------------------------------------------------- 1 | #' Autoplot method for microbenchmark objects: Prettier graphs for 2 | #' microbenchmark using ggplot2 3 | #' 4 | #' Uses ggplot2 to produce a more legible graph of microbenchmark timings. 5 | #' 6 | #' @param object A microbenchmark object. 7 | #' @param \dots Ignored. 8 | #' @param order Names of output column(s) to order the results. 9 | #' @param log If \code{TRUE} the time axis will be on log scale. 10 | #' @param unit The unit to use for graph labels. 11 | #' @param y_max The upper limit of the y axis, in the unit automatically 12 | #' chosen for the time axis (defaults to the maximum value). 13 | #' @return A ggplot2 object. 14 | #' 15 | #' @examples 16 | #' if (requireNamespace("ggplot2", quietly = TRUE)) { 17 | #' tm <- microbenchmark(rchisq(100, 0), 18 | #' rchisq(100, 1), 19 | #' rchisq(100, 2), 20 | #' rchisq(100, 3), 21 | #' rchisq(100, 5), times=1000L) 22 | #' ggplot2::autoplot(tm) 23 | #' 24 | #' # add a custom title 25 | #' ggplot2::autoplot(tm) + ggplot2::ggtitle("my timings") 26 | #' } 27 | #' @author Ari Friedman, Olaf Mersmann 28 | autoplot.microbenchmark <- function(object, ..., 29 | order=NULL, 30 | log=TRUE, 31 | unit=NULL, 32 | y_max=NULL) { 33 | if (!requireNamespace("ggplot2", quietly = TRUE)) 34 | stop("Missing package 'ggplot2'.") 35 | y_min <- 0 36 | 37 | unit <- determine_unit(object, unit) 38 | object$ntime <- convert_to_unit(object, unit) 39 | if (is.null(y_max)) { 40 | y_max <- max(object$ntime) 41 | } 42 | if (!is.null(order)) { 43 | s <- summary(object) 44 | object_colnames <- colnames(s) 45 | order <- match.arg(order, object_colnames, several.ok=TRUE) 46 | new_order <- do.call("order", c(s[, order, drop=FALSE], decreasing=TRUE)) 47 | object$expr <- factor(object$expr, levels = levels(object$expr)[new_order]) 48 | } 49 | plt <- ggplot2::ggplot(object, ggplot2::aes_string(x="expr", y="ntime")) 50 | plt <- plt + ggplot2::stat_ydensity() 51 | plt <- plt + ggplot2::scale_x_discrete(name="") 52 | 53 | y_label <- sprintf("Time (%s) for neval = %d", 54 | attr(object$ntime, "unit"), 55 | nrow(object) / length(levels(object$expr))) 56 | 57 | if (log) { 58 | y_min <- if (min(object$time) == 0) 1 else min(object$ntime) 59 | plt <- plt + ggplot2::scale_y_log10(name=y_label) 60 | } else { 61 | plt <- plt + ggplot2::scale_y_continuous(name=y_label) 62 | } 63 | plt <- plt + ggplot2::coord_flip(ylim=c(y_min , y_max)) 64 | plt <- plt + ggplot2::ggtitle("microbenchmark timings") 65 | plt 66 | } 67 | -------------------------------------------------------------------------------- /R/summary.R: -------------------------------------------------------------------------------- 1 | #' Summarize \code{microbenchmark} timings. 2 | #' 3 | #' @param object An object of class \code{microbenchmark}. 4 | #' 5 | #' @param unit What unit to print the timings in. If none is given, 6 | #' either the \code{unit} attribute of \code{object} or the option 7 | #' \code{microbenchmark.unit} is used and if neither is set 8 | #' \dQuote{t} is used. 9 | #' 10 | #' @param ... Ignored 11 | #' 12 | #' @param include_cld Calculate \code{cld} using \code{multcomp::glht()} 13 | #' and add it to the output. Set to \code{FALSE} if the calculation takes 14 | #' too long. 15 | #' 16 | #' @note The available units are nanoseconds (\code{"ns"}), 17 | #' microseconds (\code{"us"}), milliseconds (\code{"ms"}), seconds 18 | #' (\code{"s"}) and evaluations per seconds (\code{"eps"}) and 19 | #' relative runtime compared to the best median time 20 | #' (\code{"relative"}). 21 | #' 22 | #' @return A \code{data.frame} containing the aggregated results. 23 | #' 24 | #' @seealso \code{\link{print.microbenchmark}} 25 | #' @method summary microbenchmark 26 | summary.microbenchmark <- function(object, unit, ..., include_cld = TRUE) { 27 | ## Choose unit if not given based on unit attribute of object or 28 | ## global option. Default to 't' if none is set. 29 | if (missing(unit)) { 30 | unit <- NULL 31 | } 32 | unit <- determine_unit(object, unit) 33 | 34 | if (unit != "relative") 35 | object$time <- convert_to_unit(object, unit) 36 | 37 | res <- aggregate(time ~ expr, object, 38 | function(z) { 39 | tmp <- c(fivenum(z), mean(z), length(z)) 40 | tmp[c(1, 2, 6, 3, 4, 5, 7)] 41 | }) 42 | res <- cbind(res$expr, as.data.frame(res$time)) 43 | colnames(res) <- c("expr", "min", "lq", "mean", "median", "uq", "max", "neval") 44 | 45 | if (unit == "relative") { 46 | min <- res[which.min(res$median), , drop = FALSE] 47 | min$neval <- 1 # Ugly hack: Do not rescale neval 48 | res[-1] <- res[-1] / as.list(min[-1]) 49 | attr(res, "unit") <- "relative" 50 | } else { 51 | attr(res, "unit") <- attr(object$time, "unit") 52 | } 53 | 54 | if (isTRUE(include_cld) && requireNamespace("multcomp", quietly = TRUE) 55 | && nrow(res) > 1 && all(res["neval"] > 1)) { 56 | ## Try to calculate a statistically meaningful comparison. If it fails for 57 | ## any reason (f.e. the data might be constant), ignore the error. 58 | cld_time <- system.time({ 59 | tryCatch({ 60 | ops <- options(warn=-1) 61 | mdl <- lm(time ~ expr, object) 62 | comp <- multcomp::glht(mdl, multcomp::mcp(expr = "Tukey")) 63 | res$cld <- multcomp::cld(comp)$mcletters$monospacedLetters 64 | }, error=function(e) FALSE, finally=options(ops)) 65 | }) 66 | if (cld_time["elapsed"] > 5.0) { 67 | message("cld calculation took more than 5 seconds\n set", 68 | " include_cld = FALSE to skip the cld calculation") 69 | } 70 | } 71 | res 72 | } 73 | -------------------------------------------------------------------------------- /examples/callnextmethod.R: -------------------------------------------------------------------------------- 1 | library("microbenchmark") 2 | library("methods") 3 | 4 | ## Class definitions: 5 | setClass("s4_class", representation(id="character", num="numeric")) 6 | setClass("s4_subclass", contains="s4_class") 7 | setClass("s4_subsubclass", contains="s4_subclass") 8 | setClass("s4_subsubsubclass", contains="s4_subsubclass") 9 | 10 | ## Constructors: 11 | s4_class <- function(id, num) new("s4_class", id=id, num=num) 12 | s4_subclass <- function(id, num) new("s4_subclass", id=id, num=num) 13 | s4_subsubclass <- function(id, num) new("s4_subsubclass", id=id, num=num) 14 | s4_subsubsubclass <- function(id, num) new("s4_subsubsubclass", id=id, num=num) 15 | 16 | ## [ - Generic field getter using subset operator. 17 | setMethod(f="[", signature = signature("s4_class"), 18 | def=function(x, i, j, ..., drop) { 19 | if (i %in% slotNames(x)) 20 | return (slot(x, i)) 21 | return (NULL) 22 | }) 23 | 24 | setMethod(f="[", signature = signature("s4_subclass"), 25 | def=function(x, i, j, ..., drop) { 26 | if (i == "bam") 27 | return ("ham") 28 | if (i == "ham") 29 | return ("bam") 30 | callNextMethod() 31 | }) 32 | 33 | setMethod(f="[", signature = signature("s4_subsubclass"), 34 | def=function(x, i, j, ..., drop) { 35 | if (i == "foo") 36 | return ("bar") 37 | if (i == "bar") 38 | return ("foo") 39 | callNextMethod() 40 | }) 41 | 42 | setMethod(f="[", signature = signature("s4_subsubsubclass"), 43 | def=function(x, i, j, ..., drop) { 44 | if (i == "baz") 45 | return ("baz") 46 | callNextMethod() 47 | }) 48 | 49 | ## get_id - Simple generic dispatch. 50 | setGeneric(name="get_id", 51 | def=function(x) standardGeneric("get_id")) 52 | 53 | setMethod("get_id", "s4_class", function(x) x@id) 54 | 55 | ## getId - implements a mix of get_id (explicit getter) but with an 56 | ## explicit method for each subclass that calls callNextMethod(). 57 | setGeneric("getId", def=function(x) standardGeneric("getId")) 58 | setMethod("getId", "s4_class", function(x) x@id) 59 | setMethod("getId", "s4_subclass", function(x) callNextMethod()) 60 | setMethod("getId", "s4_subsubclass", function(x) callNextMethod()) 61 | setMethod("getId", "s4_subsubsubclass", function(x) callNextMethod()) 62 | 63 | ## Micro benchmark of call speed: 64 | n <- 1000L 65 | c4 <- s4_class(id="foo", num=2) 66 | sc4 <- s4_subclass(id="foo", num=2) 67 | ssc4 <- s4_subsubclass(id="foo", num=2) 68 | sssc4 <- s4_subsubsubclass(id="foo", num=2) 69 | 70 | speed <- microbenchmark(c4@id, sc4@id, ssc4@id, 71 | get_id(c4), get_id(sc4), get_id(ssc4), 72 | c4["id"], sc4["id"], ssc4["id"], sssc4["id"], 73 | getId(c4), getId(sc4), getId(ssc4), 74 | times=n) 75 | print(speed, "eps") 76 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | #https://stackoverflow.com/questions/34603415/makefile-automatic-target-generation 2 | #https://www.gnu.org/software/make/manual/make.html#Static-Pattern 3 | #https://stackoverflow.com/questions/2826029/passing-additional-variables-from-command-line-to-make 4 | #https://stackoverflow.com/questions/2214575/passing-arguments-to-make-run 5 | 6 | R_HOME = /usr 7 | 8 | PKG_PATH = ${PWD} 9 | TOP = ${PWD}/.. 10 | PKG_DESC = ${PKG_PATH}/DESCRIPTION 11 | PKG_NAME = $(shell sed -ne "s/^Package: //p" ${PKG_DESC} | tr -d '\n') 12 | PKG_VER = $(shell sed -ne "s/^Version: \(.*\)/\1/p" ${PKG_DESC} | tr -d '\n') 13 | PKG_TARGZ = $(PKG_NAME)_$(PKG_VER).tar.gz 14 | 15 | 16 | PKG_BUILD_OPTS ?= --no-build-vignettes 17 | R_LIB ?= $(shell Rscript -e 'cat(.libPaths()[1L])') 18 | 19 | PKG_INST_FILE = $(R_LIB)/${PKG_NAME}/DESCRIPTION 20 | 21 | PKG_R_FILES := $(wildcard ${PKG_PATH}/R/*.R) 22 | PKG_RD_FILES := $(wildcard ${PKG_PATH}/man/*.Rd) 23 | PKG_SRC_FILES := $(wildcard ${PKG_PATH}/src/*) 24 | PKG_HEADER_FILES := $(wildcard ${PKG_PATH}/inst/include/*h) 25 | PKG_ALL_FILES := ${PKG_PATH}/DESCRIPTION ${PKG_PATH}/NAMESPACE ${PKG_HEADER_FILES} \ 26 | $(PKG_R_FILES) $(PKG_RD_FILES) $(PKG_SRC_FILES) ${PKG_PATH}/.Rbuildignore 27 | 28 | HTML_FILES := $(patsubst %.Rmd, %.html, $(wildcard *.Rmd)) \ 29 | $(patsubst %.md, %.html, $(wildcard *.md)) 30 | 31 | UNIT_TEST_SUITE = ${PKG_PATH}/tests/doRUnit.R 32 | UNIT_TEST_FILES = $(wildcard ${PKG_PATH}/inst/unitTests/runit_*.R) 33 | 34 | .PHONY: docs build install check tests test clean 35 | 36 | all: cran 37 | 38 | #man/*.Rd depend on R/*.R files 39 | print: 40 | @echo 'path: $(PKG_PATH) \ 41 | inst_file: $(PKG_INST_FILE) \ 42 | tar.gz: $(PKG_TARGZ)' 43 | 44 | # Build package 45 | build: $(PKG_TARGZ) 46 | $(PKG_TARGZ): $(PKG_ALL_FILES) $(UNIT_TEST_FILES) $(UNIT_TEST_SUITE) 47 | @${R_HOME}/bin/R CMD build ${PKG_BUILD_OPTS} ${PKG_PATH} --no-build-vignettes 48 | 49 | # Install package 50 | install: build $(PKG_INST_FILE) 51 | $(PKG_INST_FILE): $(PKG_TARGZ) 52 | @${R_HOME}/bin/R CMD INSTALL ${PKG_TARGZ} --no-byte-compile 53 | 54 | # Run R CMD check 55 | check: docs build 56 | @_R_CHECK_CRAN_INCOMING_=false \ 57 | _PKG_TINYTEST_VERBOSE_=1 _PKG_TINYTEST_COLOR_=FALSE \ 58 | ${R_HOME}/bin/R CMD check ${PKG_TARGZ} --no-vignettes 59 | 60 | docs: ${PKG_R_FILES} 61 | @${R_HOME}/bin/Rscript -e "roxygen2::roxygenize(roclets='rd')" \ 62 | && sed -i '/^RoxygenNote/d' ${PKG_PATH}/DESCRIPTION \ 63 | && /bin/rm --force ${PKG_PATH}/src/*.o \ 64 | && /bin/rm --force ${PKG_PATH}/src/*.so 65 | 66 | # Check for CRAN 67 | cran: 68 | @${R_HOME}/bin/R CMD build ${PKG_PATH} && \ 69 | _PKG_TINYTEST_VERBOSE_=1 _PKG_TINYTEST_COLOR_=FALSE \ 70 | _R_CHECK_CRAN_INCOMING_=false ${R_HOME}/bin/R CMD check ${PKG_TARGZ} --as-cran 71 | 72 | # Run unit test suite 73 | tests: install ${UNIT_TEST_FILES} 74 | @_PKG_TINYTEST_VERBOSE_=2 _PKG_TINYTEST_COLOR_=TRUE \ 75 | ${R_HOME}/bin/Rscript ${UNIT_TEST_SUITE} 76 | 77 | html: $(HTML_FILES) 78 | 79 | %.html: %.Rmd 80 | R --slave -e "set.seed(100);rmarkdown::render('$<')" 81 | 82 | %.html: %.md 83 | R --slave -e "set.seed(100);rmarkdown::render('$<')" 84 | 85 | clean: 86 | /bin/rm --force $(HTML_FILES) ${PKG_PATH}/src/*.o ${PKG_PATH}/src/*.so 87 | -------------------------------------------------------------------------------- /inst/unitTests/runit_test_regression.R: -------------------------------------------------------------------------------- 1 | library(microbenchmark) 2 | 3 | test.unit_is_object_errors <- function() 4 | { 5 | out <- try(microbenchmark(NULL, unit=a), silent = TRUE) 6 | checkTrue(inherits(out, "try-error")) 7 | } 8 | 9 | test.unit_f_is_valid <- function() 10 | { 11 | out <- try(microbenchmark(NULL, unit="f"), silent = TRUE) 12 | checkTrue(!inherits(out, "try-error")) 13 | } 14 | 15 | test.unit_is_int_errors <- function() 16 | { 17 | out <- try(microbenchmark(NULL, unit=4), silent = TRUE) 18 | checkTrue(inherits(out, "try-error")) 19 | } 20 | 21 | kest.unit_arg_errors_before_printing <- function() 22 | { 23 | out <- try(microbenchmark(NULL, unit="foo"), silent = TRUE) 24 | checkTrue(inherits(out, "try-error")) 25 | } 26 | 27 | test.unit_arg_valid_values <- function() 28 | { 29 | check <- function(x, u) 30 | { 31 | unit <- microbenchmark:::determine_unit 32 | checkIdentical(unit(unit = u), attr(x, "unit")) 33 | } 34 | 35 | test <- function() {} 36 | 37 | values <- c("nanoseconds", "ns", 38 | "microseconds", "us", 39 | "milliseconds", "ms", 40 | "seconds", "s", "secs", 41 | "time", "t", 42 | "frequency", "f", 43 | "hz", "khz", "mhz", 44 | "eps", "relative") 45 | 46 | for (u in values) { 47 | out <- microbenchmark(test(), unit = u, times = 1) 48 | check(out, u) 49 | } 50 | } 51 | 52 | test.unit_is_null_does_not_error <- function() 53 | { 54 | out <- try(print(microbenchmark(NULL, unit = NULL)), silent = TRUE) 55 | checkTrue(!inherits(out, "try-error")) 56 | } 57 | 58 | test.simple_timing <- function() 59 | { 60 | set.seed(21) 61 | out <- microbenchmark(rnorm(1e4)) 62 | checkTrue(all(out$time > 0)) 63 | } 64 | 65 | test.get_nanotime <- function() 66 | { 67 | nt <- get_nanotime() 68 | checkTrue(nt > 0) 69 | } 70 | 71 | test.microtiming_precision <- function() 72 | { 73 | mtp <- tryCatch(microtiming_precision(), 74 | warning = function(w) w, 75 | error = function(e) e) 76 | 77 | if (is(mtp, "warning") || is(mtp, "error")) { 78 | stop(mtp$message) 79 | } 80 | } 81 | 82 | test.setup_expression <- function() 83 | { 84 | set.seed(21) 85 | x <- rnorm(10) 86 | microbenchmark(y <- rnorm(10), x, setup = set.seed(21)) 87 | checkTrue(identical(x, y)) 88 | } 89 | 90 | test.setup_expression_check <- function() 91 | { 92 | my_check <- function(values) { 93 | v1 <- values[[1]] 94 | all(sapply(values[-1], function(x) identical(v1, x))) 95 | } 96 | set.seed(21) 97 | x <- rnorm(10) 98 | microbenchmark(rnorm(10), x, check = my_check, setup = set.seed(21)) 99 | } 100 | 101 | test.setup_expression_eval_env_check <- function() 102 | { 103 | my_check <- function(values) { 104 | v1 <- values[[1]] 105 | all(sapply(values[-1], function(x) identical(v1, x))) 106 | } 107 | set.seed(21) 108 | x <- rnorm(10) 109 | microbenchmark(rnorm(n), x, check = my_check, 110 | setup = {set.seed(21); n <- 10}) 111 | } 112 | 113 | test.setup_expression_eval_env <- function() 114 | { 115 | x <- rnorm(10) 116 | microbenchmark(y <- rnorm(n), x, setup = {n <- 10}) 117 | checkTrue(length(y) == 10L) 118 | } 119 | 120 | test.expression_eval_parent_frame <- function() 121 | { 122 | fx <- function() { 1:10 } 123 | fy <- function() { 1:10 } 124 | microbenchmark(x <- fx(), y <- fy()) 125 | checkTrue(identical(x, y)) 126 | } 127 | 128 | test.setup_expression_check_equal <- function() 129 | { 130 | set.seed(21) 131 | x <- rnorm(1e5) 132 | microbenchmark(rnorm(1e5), x, check = 'equal', setup = set.seed(21)) 133 | } 134 | 135 | test.setup_expression_check_equal_failure <- function() 136 | { 137 | set.seed(21) 138 | x <- rnorm(1e5) 139 | attr(x = x, 'abc') <- 123 # add attribute 140 | out <- try(microbenchmark(rnorm(1e5), x, check = 'equal', setup = set.seed(21)), silent = T) 141 | checkTrue(inherits(out, "try-error")) 142 | } 143 | 144 | test.setup_expression_check_equivalent <- function() 145 | { 146 | set.seed(21) 147 | x <- rnorm(1e5) 148 | attr(x = x, 'abc') <- 123 # add attribute 149 | microbenchmark(rnorm(1e5), x, check = 'equivalent', setup = set.seed(21)) 150 | } 151 | 152 | test.setup_expression_check_identical <- function() 153 | { 154 | set.seed(21) 155 | x <- rnorm(1e5) 156 | microbenchmark(rnorm(1e5), x, check = 'identical', setup = set.seed(21)) 157 | } 158 | 159 | test.setup_expression_check_identical_failure <- function() 160 | { 161 | set.seed(21) 162 | x <- rnorm(1e5) 163 | attr(x = x, 'abc') <- 123 # add attribute 164 | out <- try(microbenchmark(rnorm(1e5), x, check = 'equal', setup = set.seed(21)), silent = T) 165 | checkTrue(inherits(out, "try-error")) 166 | } 167 | 168 | test.print_returns_input <- function() 169 | { 170 | x <- microbenchmark( 5 + 6, 6 + 7, times = 2) 171 | identical(x, print(x)) 172 | } 173 | -------------------------------------------------------------------------------- /configure.ac: -------------------------------------------------------------------------------- 1 | # -*- Autoconf -*- 2 | # Process this file with autoconf to produce a configure script. 3 | 4 | AC_PREREQ([2.69]) 5 | AC_INIT([microbenchmark], [VERSION], [https://github.com/joshuaulrich/microbenchmark/issues]) 6 | 7 | : ${R_HOME=`R RHOME`} 8 | if test -z "${R_HOME}"; then 9 | echo "could not determine R_HOME" 10 | exit 1 11 | fi 12 | CC=`"${R_HOME}/bin/R" CMD config CC` 13 | CFLAGS=`"${R_HOME}/bin/R" CMD config CFLAGS` 14 | CPPFLAGS=`"${R_HOME}/bin/R" CMD config CPPFLAGS` 15 | 16 | AC_CONFIG_SRCDIR([src/init.c]) 17 | AC_CONFIG_HEADERS([src/config.h]) 18 | AC_CONFIG_FILES([src/Makevars]) 19 | 20 | # Checks for programs. 21 | AC_PROG_CC 22 | 23 | # Checks for libraries. 24 | 25 | # Checks for header files. 26 | AC_CHECK_HEADERS([stdint.h stdlib.h sys/time.h]) 27 | 28 | # Checks for typedefs, structures, and compiler characteristics. 29 | ## nanotime_t is a 64-bit unsigned int 30 | AC_TYPE_UINT64_T 31 | 32 | # Checks for library functions. 33 | AC_FUNC_ERROR_AT_LINE 34 | 35 | mb_cv_have_timer="no" 36 | 37 | ## mach_absolute_time (macOS) 38 | if test "${mb_cv_have_timer}" = "no"; then 39 | AC_MSG_CHECKING(for mach_absolute_time) 40 | AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ 41 | #include 42 | ]], [[ 43 | uint64_t time; 44 | mach_timebase_info_data_t info; 45 | time = mach_absolute_time(); 46 | mach_timebase_info(&info); 47 | time * (info.numer / info.denom); 48 | ]])],[mb_cv_have_timer="yes"],[]) 49 | AC_MSG_RESULT(${mb_cv_have_timer}) 50 | if test "${mb_cv_have_timer}" = "yes"; then 51 | AC_DEFINE_UNQUOTED([MB_HAVE_MACH_TIME], [1], 52 | [Define to 1 if you have the `mach_absolute_time` function.]) 53 | fi 54 | fi 55 | 56 | # clock_gettime 57 | if test "${mb_cv_have_timer}" = "no"; then 58 | 59 | # clock_gettime is included in glibc > 2.16, and librt before 60 | libs="${LIBS}" 61 | AC_SEARCH_LIBS(clock_gettime, rt) 62 | 63 | # we have clock_gettime, now check for best clockid_t 64 | if test "${ac_cv_search_clock_gettime}" != "no"; then 65 | AC_CACHE_CHECK([for best clockid_t to use with clock_gettime], 66 | mb_cv_clockid_t, 67 | [ 68 | for clockid in CLOCK_MONOTONIC_PRECISE CLOCK_MONOTONIC_RAW \ 69 | CLOCK_HIGHRES CLOCK_MONOTONIC; do 70 | AC_LINK_IFELSE([AC_LANG_PROGRAM([[ 71 | #include 72 | ]], [[ 73 | struct timespec ts; 74 | clock_gettime($clockid, &ts); 75 | ]])],[mb_cv_clockid_t="${clockid}"],[mb_cv_clockid_t="no"]) 76 | test "${mb_cv_clockid_t}" = "no" || break 77 | done 78 | ]) 79 | 80 | LIBS="${libs}" 81 | 82 | if test "${mb_cv_clockid_t}" = "no"; then 83 | AC_MSG_WARN(cannot find a monotonic clockid_t to use with clock_gettime; an alternative clock will be used) 84 | else 85 | AC_DEFINE([MB_HAVE_CLOCK_GETTIME], [1], 86 | [Define to 1 if you have the `clock_gettime` function.]) 87 | AC_DEFINE_UNQUOTED([MB_CLOCKID_T], [$mb_cv_clockid_t], 88 | [clockid_t to use with clock_gettime]) 89 | if test "${mb_cv_clockid_t}" = "CLOCK_MONOTONIC_PRECISE"; then 90 | # CLOCK_MONOTONIC_PRECISE is FreeBSD-specific that requires __BSD_VISIBLE to use 91 | AC_DEFINE([__BSD_VISIBLE], [1], [Enable FreeBSD-specific clockid]) 92 | fi 93 | if test "${ac_cv_search_clock_gettime}" != "none required"; then 94 | AC_SUBST(MB_LIBS, $ac_cv_search_clock_gettime) 95 | fi 96 | mb_cv_have_timer="yes" 97 | fi 98 | fi 99 | fi 100 | 101 | # gethrtime 102 | if test "${mb_cv_have_timer}" = "no"; then 103 | AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ 104 | #if defined(sun) || defined(__sun) 105 | #define __EXTENSIONS__ 106 | #endif 107 | 108 | #include 109 | #include 110 | ]], [[ 111 | gethrtime(); 112 | ]])],[mb_cv_gethrtime="yes"],[mb_cv_gethrtime="no"]) 113 | 114 | if test "${mb_cv_gethrtime}" = "yes"; then 115 | AC_DEFINE_UNQUOTED([MB_HAVE_GETHRTIME], [1], 116 | [Define to 1 if you have the `gethrtime` function.]) 117 | mb_cv_have_timer="yes" 118 | fi 119 | fi 120 | 121 | # gettimeofday 122 | if test "${mb_cv_have_timer}" = "no"; then 123 | AC_MSG_WARN(cannot find a high-resolution timer. Falling back to system time, which is unreliable for benchmarks.) 124 | AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[ 125 | #include 126 | ]], [[ 127 | struct timeval tv; 128 | gettimeofday(&tv, NULL); 129 | ]])],[mb_cv_gettimeofday="yes"],[mb_cv_gettimeofday="no"]) 130 | 131 | if test "${mb_cv_func_gettimeofday}" = "yes"; then 132 | AC_DEFINE_UNQUOTED([MB_HAVE_GETTIMEOFDAY], [1], 133 | [Define to 1 if you have the `gettimeofday` function.]) 134 | mb_cv_have_timer="yes" 135 | fi 136 | fi 137 | 138 | # nothing 139 | if test "${mb_cv_have_timer}" = "no"; then 140 | AC_MSG_ERROR(cannot find a valid timing function.) 141 | fi 142 | 143 | AC_OUTPUT 144 | -------------------------------------------------------------------------------- /.github/CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | ### Have a question? 2 | 3 | Please do not open an issue to ask a question about how to use the package. 4 | Instead, ask your question on [Stack Overflow](http://stackoverflow.com/questions/tagged/r). 5 | 6 | ---- 7 | 8 | ### Have a bug report or feature request? 9 | 10 | 1. Create a *minimal* reproducible example. The process of creating a 11 | [*minimal*, reproducible example](http://stackoverflow.com/q/5963269/271616) 12 | should identify the package that contains the bug or should contain the 13 | feature. Please email the maintainer if you're unsure where to create an 14 | issue. 15 | 1. Search current open GitHub [issues](https://github.com/joshuaulrich/microbenchmark/issues) 16 | to check if the bug/feature has already been reported/requested. 17 | 1. Ensure your fork and local copy are up-to-date, and verify the bug still 18 | exists in the HEAD of the master branch. 19 | 1. If the bug exists in the HEAD of master, and you can't find an open issue, 20 | then [open a new issue](https://github.com/joshuaulrich/microbenchmark/issues). 21 | Please be sure to: 22 | * Use an informative and descriptive title, 23 | * Describe the expected behavior and why you think the current behavior is 24 | a bug. 25 | * Include as much relevant information as possible; at minimum: 26 | * a [*minimal*, reproducible example](http://stackoverflow.com/q/5963269/271616) 27 | * the output from `sessionInfo()` 28 | 29 | ---- 30 | 31 | ### Want to submit a pull request? 32 | 33 | 1. Changes that are purely cosmetic in nature (e.g. whitespace changes, code 34 | formatting, etc) will generally not be accepted because they do not add to 35 | the stability, functionality, or testability of the project. 36 | 1. Unless the change is extremely trivial (e.g. typos), please 37 | [create an issue](#have-a-bug-report-or-feature-request) and wait for 38 | feedback *before* you start work on a pull request. That will avoid the 39 | possibility you spend time on a patch that won't be merged. 40 | 1. Create a branch for the feature/bug fix reported in the issue. Please use a 41 | short and descriptive branch name that starts with the issue number (e.g. 42 | 123_custom_function). Use that branch as the base for your pull request. 43 | Pull requests on your version of `master` will not be accepted, because 44 | they can make it difficult for you to update your fork if your pull request 45 | isn't incorporated verbatim. 46 | 1. A pull request should only be for one issue, so please `git rebase -i` and 47 | squash the commits on your feature branch into one commit before creating 48 | the pull request. Please use `git commit --amend` to amend your commit if 49 | you are asked to make changes. It's okay to force update your pull request 50 | with `git push --force`. 51 | 1. Please write a great [commit message](#commit-messages). 52 | 1. It would be much appreciated if you also add tests that cover your changes. 53 | 54 | ---- 55 | 56 | ### Commit Messages 57 | 58 | Follow the [The Seven Rules](http://chris.beams.io/posts/git-commit/#seven-rules) 59 | of [How to Write a Git Commit Message](http://chris.beams.io/posts/git-commit/). 60 | Pay particular attention to [rule 7: Use the body to explain what and why 61 | versus how](http://chris.beams.io/posts/git-commit/#why-not-how). The body 62 | should also include the motivation for the change and how it compares to prior 63 | behavior. 64 | 65 | If the commit is to fix a bug or add a feature, the commit message should 66 | contain enough information to understand the bug/feature without having to 67 | reference an external tracker (e.g. GitHub issues). But please *do reference 68 | the GitHub issue* on the last line of your commit message body. For example, 69 | here is a great [xts commit message](https://github.com/joshuaulrich/xts/commit/ce1b667ab7c38cb2633fca0075652a69e5d2a343): 70 | 71 | ```text 72 | Correct endpoints when index is before the epoch 73 | 74 | The endpoints C code casts the double index to long, which truncates 75 | it toward zero. This behavior is desired when the index is positive, 76 | because it moves the endpoint *back* in time. But when the index is 77 | negative, truncating toward zero moves the endpoint *forward* in time. 78 | 79 | This is also an issue if the index value is stored as integer, since the 80 | C99 specification states that integer division truncates toward zero. 81 | 82 | If the first index value is less than zero, branch into a special case 83 | to handle pre-epoch index values. This avoids performance degradation 84 | if all index values are after the epoch. 85 | 86 | If the index value is less than zero, simply add 1 to offset the 87 | truncation toward zero. We also need to furthre adjust the potential 88 | endpoint value if the index is exactly equal to zero. 89 | 90 | Fixes #144. 91 | ``` 92 | 93 | ---- 94 | 95 | ### References: 96 | 1. The [data.table Contributing Guide](https://github.com/Rdatatable/data.table/blob/master/Contributing.md). 97 | 1. The [Atom Contributing Guide](https://github.com/atom/atom/blob/master/CONTRIBUTING.md). 98 | 1. How to create a [minimal, reproducible example](http://stackoverflow.com/q/5963269/271616). 99 | 1. [How to Write a Git Commit Message](http://chris.beams.io/posts/git-commit/). 100 | 1. The [Mercurial Contributing Guide](https://www.mercurial-scm.org/wiki/ContributingChanges). 101 | 1. The [Hugo Contributing Guide](https://github.com/spf13/hugo/blob/master/CONTRIBUTING.md). 102 | 103 | -------------------------------------------------------------------------------- /src/nanotimer.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | #include 6 | #include 7 | 8 | #ifdef HAVE_CONFIG_H 9 | #include "config.h" 10 | #endif 11 | 12 | #include "sexp_macros.h" 13 | #include "do_nothing.h" 14 | 15 | typedef uint64_t nanotime_t; 16 | 17 | #if defined(WIN32) 18 | #include "nanotimer_windows.h" 19 | #elif defined(MB_HAVE_MACH_TIME) 20 | #include "nanotimer_macosx.h" 21 | #elif defined(MB_HAVE_CLOCK_GETTIME) && defined(MB_CLOCKID_T) 22 | #include "nanotimer_clock_gettime.h" 23 | #elif defined(MB_HAVE_GETHRTIME) 24 | #include "nanotimer_rtposix.h" 25 | #elif defined(MB_HAVE_GETTIMEOFDAY) 26 | #include "nanotimer_gettimeofday.h" 27 | #else /* ./configure should prevent this, but just in case... */ 28 | #error "Unsupported OS." 29 | #endif 30 | 31 | #if defined(__GNUC__) 32 | #define NOINLINE __attribute__((noinline)) 33 | #else 34 | #define NOINLINE 35 | #endif 36 | 37 | nanotime_t estimate_overhead(SEXP s_rho, int rounds) { 38 | int i, n_back_in_time = 0; 39 | int observed_overhead = FALSE; 40 | /* Estimate minimal overhead and warm up the machine ... */ 41 | nanotime_t start, end, overhead = UINT64_MAX; 42 | for (i = 0; i < rounds; ++i) { 43 | start = get_nanotime(); 44 | do_nothing(); 45 | end = get_nanotime(); 46 | 47 | const nanotime_t diff = end - start; 48 | if (start < end && diff < overhead) { 49 | observed_overhead = TRUE; 50 | overhead = diff; 51 | } else if (start > end) { 52 | n_back_in_time++; 53 | } 54 | } 55 | if (!observed_overhead) { 56 | warning("Could not measure overhead. Your clock might lack precision."); 57 | overhead = 0; 58 | } else if (UINT64_MAX == overhead) { 59 | error("Observed overhead too large."); 60 | } 61 | if (n_back_in_time > 0) { 62 | warning("Observed negative overhead in %i cases.", 63 | n_back_in_time); 64 | } 65 | return overhead; 66 | } 67 | 68 | SEXP do_microtiming_precision(SEXP s_rho, SEXP s_times, SEXP s_warmup) { 69 | UNPACK_INT(s_warmup, warmup); 70 | UNPACK_INT(s_times, times); 71 | int n = 0; 72 | nanotime_t overhead = estimate_overhead(s_rho, warmup); 73 | nanotime_t start, end; 74 | SEXP s_ret; 75 | PROTECT(s_ret = allocVector(REALSXP, times)); 76 | while (n < times) { 77 | start = get_nanotime(); 78 | end = get_nanotime(); 79 | if (start < end) { 80 | REAL(s_ret)[n] = end - start - overhead; 81 | n++; 82 | } 83 | } 84 | UNPROTECT(1); /* s_ret */ 85 | return s_ret; 86 | } 87 | 88 | SEXP do_get_nanotime(void) { 89 | return ScalarReal(get_nanotime() * 1.0); 90 | } 91 | 92 | SEXP do_microtiming(SEXP s_exprs, SEXP s_rho, SEXP s_warmup, SEXP s_setup) { 93 | nanotime_t start, end, overhead; 94 | int i, n_under_overhead = 0, n_start_end_equal = 0; 95 | R_len_t n_exprs = 0; 96 | SEXP s_ret, s_expr; 97 | double *ret; 98 | 99 | UNPACK_INT(s_warmup, warmup); 100 | 101 | /* Expressions */ 102 | n_exprs = LENGTH(s_exprs); 103 | 104 | /* Environment in which to evaluate */ 105 | if(!isEnvironment(s_rho)) 106 | error("'s_rho' should be an environment"); 107 | 108 | /* Return value: */ 109 | PROTECT(s_ret = allocVector(REALSXP, n_exprs)); 110 | ret = REAL(s_ret); 111 | 112 | /* Estimate minimal overhead and warm up the machine ... */ 113 | overhead = estimate_overhead(s_rho, warmup); 114 | 115 | /* Actual timing... */ 116 | for (i = 0; i < n_exprs; ++i) { 117 | s_expr = VECTOR_ELT(s_exprs, i); 118 | if (s_setup != R_NilValue) { 119 | eval(s_setup, s_rho); 120 | } 121 | start = get_nanotime(); 122 | eval(s_expr, s_rho); 123 | end = get_nanotime(); 124 | 125 | if (start < end) { 126 | const nanotime_t diff = end - start; 127 | if (diff < overhead) { 128 | ret[i] = 0.0; 129 | n_under_overhead++; 130 | } else { 131 | ret[i] = diff - overhead; 132 | } 133 | } else if (start == end) { 134 | ++n_start_end_equal; 135 | ret[i] = 0.0; 136 | } else { 137 | error("Measured negative execution time! Please investigate and/or " 138 | "contact the package author."); 139 | } 140 | 141 | /* Housekeeping */ 142 | R_CheckUserInterrupt(); 143 | /* R_gc(); */ 144 | } 145 | 146 | /* Issue waring if we observed some timings below the estimated 147 | * overhead. 148 | */ 149 | if (n_under_overhead > 0) { 150 | if (n_under_overhead == 1) { 151 | warning("Estimated overhead was greater than measured evaluation " 152 | "time in 1 run."); 153 | } else { 154 | warning("Estimated overhead was greater than measured evaluation " 155 | "time in %i runs.", n_under_overhead); 156 | } 157 | } 158 | if (n_start_end_equal > 0) { 159 | if (n_start_end_equal == 1) { 160 | warning("Could not measure a positive execution time for one " 161 | "evaluation."); 162 | } else { 163 | warning("Could not measure a positive execution time for %i " 164 | "evaluations.", n_start_end_equal); 165 | } 166 | } 167 | if (n_under_overhead + n_start_end_equal == n_exprs) { 168 | error("All timed evaluations were either smaller than the estimated " 169 | "overhead or zero. The most likely cause is a low resolution " 170 | "clock. Feel free to contact the package maintainer for debug " 171 | "the issue further."); 172 | } 173 | UNPROTECT(1); /* s_ret */ 174 | return s_ret; 175 | } 176 | -------------------------------------------------------------------------------- /man/microbenchmark.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/microbenchmark.R 3 | \name{microbenchmark} 4 | \alias{microbenchmark} 5 | \title{Sub-millisecond accurate timing of expression evaluation.} 6 | \usage{ 7 | microbenchmark( 8 | ..., 9 | list = NULL, 10 | times = 100L, 11 | unit = NULL, 12 | check = NULL, 13 | control = list(), 14 | setup = NULL 15 | ) 16 | } 17 | \arguments{ 18 | \item{...}{Expressions to benchmark.} 19 | 20 | \item{list}{List of unevaluated expressions to benchmark.} 21 | 22 | \item{times}{Number of times to evaluate each expression.} 23 | 24 | \item{unit}{Default unit used in \code{summary} and \code{print}.} 25 | 26 | \item{check}{A function to check if the expressions are equal. By default \code{NULL} which omits the check. 27 | In addition to a function, a string can be supplied. 28 | The string \sQuote{equal} will compare all values using \code{\link{all.equal}}, \sQuote{equivalent} will compare all values using \code{\link{all.equal}} and check.attributes = FALSE, and \sQuote{identical} will compare all values using \code{\link{identical}}.} 29 | 30 | \item{control}{List of control arguments. See Details.} 31 | 32 | \item{setup}{An unevaluated expression to be run (untimed) before each benchmark expression.} 33 | } 34 | \value{ 35 | Object of class \sQuote{microbenchmark}, a data frame with 36 | columns \code{expr} and \code{time}. \code{expr} contains the 37 | deparsed expression as passed to \code{microbenchmark} or the name 38 | of the argument if the expression was passed as a named 39 | argument. \code{time} is the measured execution time of the 40 | expression in nanoseconds. The order of the observations in the 41 | data frame is the order in which they were executed. 42 | } 43 | \description{ 44 | \code{microbenchmark} serves as a more accurate replacement of the 45 | often seen \code{system.time(replicate(1000, expr))} 46 | expression. It tries hard to accurately measure only the time it 47 | takes to evaluate \code{expr}. To achieved this, the 48 | sub-millisecond (supposedly nanosecond) accurate timing functions 49 | most modern operating systems provide are used. Additionally all 50 | evaluations of the expressions are done in C code to minimize any 51 | overhead. 52 | } 53 | \details{ 54 | This function is only meant for micro-benchmarking small pieces of 55 | source code and to compare their relative performance 56 | characteristics. You should generally avoid benchmarking larger 57 | chunks of your code using this function. Instead, try using the R 58 | profiler to detect hot spots and consider rewriting them in C/C++ 59 | or FORTRAN. 60 | 61 | The \code{control} list can contain the following entries: 62 | \describe{ 63 | \item{order}{the order in which the expressions are evaluated. 64 | \dQuote{random} (the default) randomizes the execution order, 65 | \dQuote{inorder} executes each expression in order and 66 | \dQuote{block} executes all repetitions of each expression 67 | as one block.} 68 | \item{warmup}{the number of iterations to run the timing code before 69 | evaluating the expressions in \dots. These warm-up iterations are used 70 | to estimate the timing overhead as well as spinning up the processor 71 | from any sleep or idle states it might be in. The default value is 2.} 72 | } 73 | } 74 | \note{ 75 | Depending on the underlying operating system, different 76 | methods are used for timing. On Windows the 77 | \code{QueryPerformanceCounter} interface is used to measure the 78 | time passed. For Linux the \code{clock_gettime} API is used and on 79 | Solaris the \code{gethrtime} function. Finally on MacOS X the, 80 | undocumented, \code{mach_absolute_time} function is used to avoid 81 | a dependency on the CoreServices Framework. 82 | 83 | Before evaluating each expression \code{times} times, the overhead 84 | of calling the timing functions and the C function call overhead 85 | are estimated. This estimated overhead is subtracted from each 86 | measured evaluation time. Should the resulting timing be negative, 87 | a warning is thrown and the respective value is replaced by 88 | \code{0}. If the timing is zero, a warning is raised. 89 | Should all evaluations result in one of the two error conditions described above, an error is raised. 90 | 91 | One platform on which the clock resolution is known to be too low to measure short runtimes with the required precision is 92 | Oracle\if{html}{\out{®}}\if{latex}{\out{\textregistered\ }}\if{text}{(R)} 93 | Solaris 94 | on some 95 | SPARC\if{html}{\out{®}}\if{latex}{\out{\textregistered\ }}\if{text}{(R)} 96 | hardware. 97 | Reports of other platforms with similar problems are welcome. 98 | Please contact the package maintainer. 99 | } 100 | \examples{ 101 | ## Measure the time it takes to dispatch a simple function call 102 | ## compared to simply evaluating the constant \code{NULL} 103 | f <- function() NULL 104 | res <- microbenchmark(NULL, f(), times=1000L) 105 | 106 | ## Print results: 107 | print(res) 108 | 109 | ## Plot results: 110 | boxplot(res) 111 | 112 | ## Pretty plot: 113 | if (requireNamespace("ggplot2")) { 114 | ggplot2::autoplot(res) 115 | } 116 | 117 | ## Example check usage 118 | my_check <- function(values) { 119 | all(sapply(values[-1], function(x) identical(values[[1]], x))) 120 | } 121 | 122 | f <- function(a, b) 123 | 2 + 2 124 | 125 | a <- 2 126 | ## Check passes 127 | microbenchmark(2 + 2, 2 + a, f(2, a), f(2, 2), check=my_check) 128 | \dontrun{ 129 | a <- 3 130 | ## Check fails 131 | microbenchmark(2 + 2, 2 + a, f(2, a), f(2, 2), check=my_check) 132 | } 133 | ## Example setup usage 134 | set.seed(21) 135 | x <- rnorm(10) 136 | microbenchmark(x, rnorm(10), check=my_check, setup=set.seed(21)) 137 | ## Will fail without setup 138 | \dontrun{ 139 | microbenchmark(x, rnorm(10), check=my_check) 140 | } 141 | ## using check 142 | a <- 2 143 | microbenchmark(2 + 2, 2 + a, sum(2, a), sum(2, 2), check='identical') 144 | microbenchmark(2 + 2, 2 + a, sum(2, a), sum(2, 2), check='equal') 145 | attr(a, 'abc') <- 123 146 | microbenchmark(2 + 2, 2 + a, sum(2, a), sum(2, 2), check='equivalent') 147 | ## check='equal' will fail due to difference in attribute 148 | \dontrun{ 149 | microbenchmark(2 + 2, 2 + a, sum(2, a), sum(2, 2), check='equal') 150 | } 151 | } 152 | \seealso{ 153 | \code{\link{print.microbenchmark}} to display and 154 | \code{\link{boxplot.microbenchmark}} or 155 | \code{\link{autoplot.microbenchmark}} to plot the results. 156 | } 157 | \author{ 158 | Olaf Mersmann 159 | } 160 | -------------------------------------------------------------------------------- /R/internal.R: -------------------------------------------------------------------------------- 1 | ## Internal utility functions 2 | 3 | # Internal helper functions that returns a generic error if timings fail. 4 | .all_na_stop <- function() { 5 | msg <- "All measured timings are NA. This is bad! 6 | 7 | There are several causes for this. The most likely are 8 | 9 | * You are running under a hypervisor. This can do all sorts of things 10 | to the timing functions of your operating system. 11 | 12 | * You have frequency scaling turned on. Most modern CPUs can reduce 13 | their core frequency if they are not busy. microbenchmark tries 14 | hard to spin up the CPU before the actual timing, but there is no 15 | guarantee this works, so you are advised to disable this 16 | feature. Under Linux this can be done using the 'cpufreq' 17 | utilities. 18 | 19 | * You have a machine with many CPU cores and the timers provided by 20 | your operating system are not synchronized across cores. Your best 21 | bet is to peg your R process to a single core. On Linux systems, 22 | this can be achieved using the 'taskset' utility. 23 | 24 | * Your machine is super fast. If the difference between the estimated 25 | overhead and the actual execution time is zero (or possibly even 26 | negative), you will get this error. Sorry, 27 | you're out of luck, benchmark more complex code. 28 | 29 | If this problem persists for you, please contact me and I will try to 30 | resolve the issue with you." 31 | 32 | stop(msg, call.=FALSE) 33 | } 34 | 35 | #' Convert timings to different units. 36 | #' 37 | #' The following units of time are supported \describe{ 38 | #' \item{\dQuote{ns}}{Nanoseconds.} 39 | #' \item{\dQuote{us}}{Microseconds.} 40 | #' \item{\dQuote{ms}}{Milliseconds.} 41 | #' \item{\dQuote{s}}{Seconds.} 42 | #' \item{\dQuote{t}}{Appropriately prefixed time unit.} 43 | #' \item{\dQuote{hz}}{Hertz / evaluations per second.} 44 | #' \item{\dQuote{eps}}{Evaluations per second / Hertz.} 45 | #' \item{\dQuote{khz}}{Kilohertz / 1000s of evaluations per second.} 46 | #' \item{\dQuote{mhz}}{Megahertz / 1000000s of evaluations per second.} 47 | #' \item{\dQuote{f}}{Appropriately prefixed frequency unit.} 48 | #' } 49 | #' 50 | #' @param object A \code{microbenchmark} object. 51 | #' @param unit A unit of time. See details. 52 | #' 53 | #' @return A matrix containing the converted time values with an 54 | #' attribute \code{unit} which is a printable name of the unit of 55 | #' time. 56 | #' 57 | #' @author Olaf Mersmann 58 | #' 59 | #' @keywords internal 60 | convert_to_unit <- function(object, unit) 61 | { 62 | unit <- determine_unit(object, unit) 63 | x <- object$time 64 | 65 | switch (unit, 66 | t=unit <- sprintf ("%ss", find_prefix(x * 1e-9, 67 | minexp = -9, maxexp = 0, mu = FALSE)), 68 | f=unit <- sprintf ("%shz", find_prefix(1e9 / x, 69 | minexp = 0, maxexp = 6, mu = FALSE)) 70 | ) 71 | unit <- tolower(unit) 72 | switch (unit, 73 | ns ={attr(x, "unit") <- "nanoseconds" ; unclass(x )}, 74 | us ={attr(x, "unit") <- "microseconds" ; unclass(x / 1e3)}, 75 | ms ={attr(x, "unit") <- "milliseconds" ; unclass(x / 1e6)}, 76 | s ={attr(x, "unit") <- "seconds" ; unclass(x / 1e9)}, 77 | eps ={attr(x, "unit") <- "evaluations per second"; unclass(1e9 / x)}, 78 | hz ={attr(x, "unit") <- "hertz" ; unclass(1e9 / x)}, 79 | khz ={attr(x, "unit") <- "kilohertz" ; unclass(1e6 / x)}, 80 | mhz ={attr(x, "unit") <- "megahertz" ; unclass(1e3 / x)}, 81 | stop("Unknown unit '", unit, "'.") 82 | ) 83 | } 84 | 85 | #' Find SI prefix for unit 86 | #' 87 | #' @param x a numeric 88 | #' @param f function that produces the number from \code{x} that is used to 89 | #' determine the prefix, e.g. \code{\link[base]{min}} or 90 | #' \code{\link[stats]{median}}. 91 | #' @param minexp minimum (decimal) exponent to consider, 92 | #' e.g. -3 to suppress prefixes smaller than milli (m). 93 | #' @param maxexp maximum (decimal) exponent to consider, 94 | #' e.g. 3 to suppress prefixes larger than kilo (k). 95 | #' @param mu if \code{TRUE}, should a proper mu be used for micro, otherwise use 96 | #' u as ASCII-compatible replacement 97 | #' 98 | #' @return character with the SI prefix 99 | #' @author Claudia Beleites 100 | #' 101 | #' @keywords internal 102 | find_prefix <- function (x, f=min, minexp=-Inf, maxexp=Inf, mu=TRUE) { 103 | prefixes <- c ("y", "z", "a", "f", "p", "n", "u", "m", "", 104 | "k", "M", "G", "T", "P", "E", "Z", "Y") 105 | if (mu) prefixes [7] <- "\u03bc" 106 | 107 | if (is.numeric (minexp)) minexp <- floor (minexp / 3) 108 | if (is.numeric (minexp)) maxexp <- floor (maxexp / 3) 109 | 110 | e3 <- floor (log10 (f (x)) / 3) 111 | e3 <- max (e3, minexp, -8) # prefixes go from 10^-24 = 10^(3 * -8) 112 | e3 <- min (e3, maxexp, 8) # to 10^24 = 10^(3 * 8) 113 | 114 | prefixes [e3 + 9] # e3 of -8 => index 1 115 | } 116 | 117 | #' Return first non null argument. 118 | #' 119 | #' This function is useful when processing complex arguments with multiple 120 | #' possible defaults based on other arguments that may or may not have been 121 | #' provided. 122 | #' 123 | #' @param ... List of values. 124 | #' @return First non null element in \code{...}. 125 | #' 126 | #' @author Olaf Mersmann 127 | #' 128 | #' @keywords internal 129 | coalesce <- function(...) { 130 | isnotnull <- function(x) !is.null(x) 131 | Find(isnotnull, list(...)) 132 | } 133 | 134 | #' Normalize timing units to one of the supported values 135 | #' 136 | #' We support the following units of time 137 | #' \describe{ 138 | #' \item{\dQuote{ns}, \dQuote{nanoseconds}}{} 139 | #' \item{\dQuote{us}, \dQuote{microseconds}}{} 140 | #' \item{\dQuote{ms}, \dQuote{milliseconds}}{} 141 | #' \item{\dQuote{s}, \dQuote{secs}, \dQuote{seconds}}{} 142 | #' \item{\dQuote{t}, \dQuote{time}}{Appropriately prefixed time unit.} 143 | #' \item{\dQuote{eps}}{Evaluations per second / Hertz.} 144 | #' \item{\dQuote{hz}}{Hertz / evaluations per second.} 145 | #' \item{\dQuote{khz}}{Kilohertz / 1000s of evaluations per second.} 146 | #' \item{\dQuote{mhz}}{Megahertz / 1000000s of evaluations per second.} 147 | #' \item{\dQuote{f}, \dQuote{frequency}}{Appropriately prefixed frequency unit.} 148 | #' } 149 | #' 150 | #' @param object A 'microbenchmark' object. 151 | #' @param unit A unit of time. See details. 152 | #' 153 | #' @return A matrix containing the converted time values with an 154 | #' attribute \code{unit} which is a printable name of the unit of 155 | #' time. 156 | #' 157 | #' @author Joshua M. Ulrich 158 | #' 159 | #' @keywords internal 160 | determine_unit <- 161 | function(object = NULL, 162 | unit = NULL) 163 | { 164 | # all supported unit values 165 | values <- c("nanoseconds", "ns", 166 | "microseconds", "us", 167 | "milliseconds", "ms", 168 | "seconds", 169 | "time", "auto", 170 | "frequency", 171 | "hz", "khz", "mhz", 172 | "eps", "relative") 173 | 174 | # Order of precedence: 175 | # 1) 'unit' argument 176 | # 2) 'unit' attribute on 'object' argument 177 | # 3) 'microbenchmark.unit' option 178 | object_unit <- attr(object, "unit") 179 | if (is.null(unit)) { 180 | if (is.null(object_unit)) { 181 | unit <- getOption("microbenchmark.unit", "auto") 182 | } else { 183 | unit <- object_unit 184 | } 185 | } else { 186 | # include support for 'secs' because it doesn't match 'seconds' 187 | unit <- if (unit == "secs") "seconds" else unit 188 | } 189 | 190 | unit <- tolower(unit) 191 | unit <- match.arg(unit, values) 192 | 193 | unit <- 194 | switch(unit, 195 | nanoseconds = , 196 | ns = "ns", 197 | microseconds = , 198 | us = "us", 199 | milliseconds = , 200 | ms = "ms", 201 | seconds = "s", 202 | auto = , 203 | time = "t", 204 | frequency = "f", 205 | hz = "hz", 206 | khz = "khz", 207 | mhz = "mhz", 208 | eps = "eps", 209 | relative = "relative") 210 | unit 211 | } 212 | -------------------------------------------------------------------------------- /R/microbenchmark.R: -------------------------------------------------------------------------------- 1 | #' Sub-millisecond accurate timing of expression evaluation. 2 | #' 3 | #' \code{microbenchmark} serves as a more accurate replacement of the 4 | #' often seen \code{system.time(replicate(1000, expr))} 5 | #' expression. It tries hard to accurately measure only the time it 6 | #' takes to evaluate \code{expr}. To achieved this, the 7 | #' sub-millisecond (supposedly nanosecond) accurate timing functions 8 | #' most modern operating systems provide are used. Additionally all 9 | #' evaluations of the expressions are done in C code to minimize any 10 | #' overhead. 11 | #' 12 | #' This function is only meant for micro-benchmarking small pieces of 13 | #' source code and to compare their relative performance 14 | #' characteristics. You should generally avoid benchmarking larger 15 | #' chunks of your code using this function. Instead, try using the R 16 | #' profiler to detect hot spots and consider rewriting them in C/C++ 17 | #' or FORTRAN. 18 | #' 19 | #' The \code{control} list can contain the following entries: 20 | #' \describe{ 21 | #' \item{order}{the order in which the expressions are evaluated. 22 | #' \dQuote{random} (the default) randomizes the execution order, 23 | #' \dQuote{inorder} executes each expression in order and 24 | #' \dQuote{block} executes all repetitions of each expression 25 | #' as one block.} 26 | #' \item{warmup}{the number of iterations to run the timing code before 27 | #' evaluating the expressions in \dots. These warm-up iterations are used 28 | #' to estimate the timing overhead as well as spinning up the processor 29 | #' from any sleep or idle states it might be in. The default value is 2.} 30 | #' } 31 | #' 32 | #' @note Depending on the underlying operating system, different 33 | #' methods are used for timing. On Windows the 34 | #' \code{QueryPerformanceCounter} interface is used to measure the 35 | #' time passed. For Linux the \code{clock_gettime} API is used and on 36 | #' Solaris the \code{gethrtime} function. Finally on MacOS X the, 37 | #' undocumented, \code{mach_absolute_time} function is used to avoid 38 | #' a dependency on the CoreServices Framework. 39 | #' 40 | #' Before evaluating each expression \code{times} times, the overhead 41 | #' of calling the timing functions and the C function call overhead 42 | #' are estimated. This estimated overhead is subtracted from each 43 | #' measured evaluation time. Should the resulting timing be negative, 44 | #' a warning is thrown and the respective value is replaced by 45 | #' \code{0}. If the timing is zero, a warning is raised. 46 | #' Should all evaluations result in one of the two error conditions described above, an error is raised. 47 | #' 48 | #' One platform on which the clock resolution is known to be too low to measure short runtimes with the required precision is 49 | #' Oracle\if{html}{\out{®}}\if{latex}{\out{\textregistered\ }}\if{text}{(R)} 50 | #' Solaris 51 | #' on some 52 | #' SPARC\if{html}{\out{®}}\if{latex}{\out{\textregistered\ }}\if{text}{(R)} 53 | #' hardware. 54 | #' Reports of other platforms with similar problems are welcome. 55 | #' Please contact the package maintainer. 56 | #' 57 | #' @param ... Expressions to benchmark. 58 | #' @param list List of unevaluated expressions to benchmark. 59 | #' @param times Number of times to evaluate each expression. 60 | #' @param check A function to check if the expressions are equal. By default \code{NULL} which omits the check. 61 | #' In addition to a function, a string can be supplied. 62 | #' The string \sQuote{equal} will compare all values using \code{\link{all.equal}}, \sQuote{equivalent} will compare all values using \code{\link{all.equal}} and check.attributes = FALSE, and \sQuote{identical} will compare all values using \code{\link{identical}}. 63 | #' @param control List of control arguments. See Details. 64 | #' @param unit Default unit used in \code{summary} and \code{print}. 65 | #' @param setup An unevaluated expression to be run (untimed) before each benchmark expression. 66 | #' 67 | #' @return Object of class \sQuote{microbenchmark}, a data frame with 68 | #' columns \code{expr} and \code{time}. \code{expr} contains the 69 | #' deparsed expression as passed to \code{microbenchmark} or the name 70 | #' of the argument if the expression was passed as a named 71 | #' argument. \code{time} is the measured execution time of the 72 | #' expression in nanoseconds. The order of the observations in the 73 | #' data frame is the order in which they were executed. 74 | #' 75 | #' @seealso \code{\link{print.microbenchmark}} to display and 76 | #' \code{\link{boxplot.microbenchmark}} or 77 | #' \code{\link{autoplot.microbenchmark}} to plot the results. 78 | #' 79 | #' @examples 80 | #' ## Measure the time it takes to dispatch a simple function call 81 | #' ## compared to simply evaluating the constant \code{NULL} 82 | #' f <- function() NULL 83 | #' res <- microbenchmark(NULL, f(), times=1000L) 84 | #' 85 | #' ## Print results: 86 | #' print(res) 87 | #' 88 | #' ## Plot results: 89 | #' boxplot(res) 90 | #' 91 | #' ## Pretty plot: 92 | #' if (requireNamespace("ggplot2")) { 93 | #' ggplot2::autoplot(res) 94 | #' } 95 | #' 96 | #' ## Example check usage 97 | #' my_check <- function(values) { 98 | #' all(sapply(values[-1], function(x) identical(values[[1]], x))) 99 | #' } 100 | #' 101 | #' f <- function(a, b) 102 | #' 2 + 2 103 | #' 104 | #' a <- 2 105 | #' ## Check passes 106 | #' microbenchmark(2 + 2, 2 + a, f(2, a), f(2, 2), check=my_check) 107 | #' \dontrun{ 108 | #' a <- 3 109 | #' ## Check fails 110 | #' microbenchmark(2 + 2, 2 + a, f(2, a), f(2, 2), check=my_check) 111 | #' } 112 | #' ## Example setup usage 113 | #' set.seed(21) 114 | #' x <- rnorm(10) 115 | #' microbenchmark(x, rnorm(10), check=my_check, setup=set.seed(21)) 116 | #' ## Will fail without setup 117 | #' \dontrun{ 118 | #' microbenchmark(x, rnorm(10), check=my_check) 119 | #' } 120 | #' ## using check 121 | #' a <- 2 122 | #' microbenchmark(2 + 2, 2 + a, sum(2, a), sum(2, 2), check='identical') 123 | #' microbenchmark(2 + 2, 2 + a, sum(2, a), sum(2, 2), check='equal') 124 | #' attr(a, 'abc') <- 123 125 | #' microbenchmark(2 + 2, 2 + a, sum(2, a), sum(2, 2), check='equivalent') 126 | #' ## check='equal' will fail due to difference in attribute 127 | #' \dontrun{ 128 | #' microbenchmark(2 + 2, 2 + a, sum(2, a), sum(2, 2), check='equal') 129 | #' } 130 | #' @author Olaf Mersmann 131 | microbenchmark <- function(..., list=NULL, 132 | times=100L, 133 | unit=NULL, 134 | check=NULL, 135 | control=list(), 136 | setup=NULL) { 137 | stopifnot(times == as.integer(times)) 138 | if (!missing(unit) && !is.null(unit)) 139 | stopifnot(is.character(unit), length(unit) == 1L) 140 | 141 | unit <- determine_unit(unit = unit) 142 | 143 | control[["warmup"]] <- coalesce(control[["warmup"]], 2^18L) 144 | control[["order"]] <- coalesce(control[["order"]], "random") 145 | 146 | stopifnot(as.integer(control$warmup) == control$warmup) 147 | 148 | exprs <- c(as.list(match.call(expand.dots = FALSE)$`...`), list) 149 | nm <- names(exprs) 150 | exprnm <- sapply(exprs, function(e) paste(deparse(e), collapse=" ")) 151 | if (is.null(nm)) 152 | nm <- exprnm 153 | else 154 | nm[nm == ""] <- exprnm[nm == ""] 155 | names(exprs) <- nm 156 | 157 | env <- parent.frame() 158 | setup <- substitute(setup) 159 | 160 | if (!is.null(check)) { 161 | setupexpr <- as.expression(setup) 162 | checkexprs <- lapply(exprs, function(e) c(setupexpr, e)) 163 | 164 | ## Evaluate values in parent environment 165 | values <- lapply(checkexprs, eval, env) 166 | if (is.character(check) && isTRUE(check == 'equal')) { 167 | check <- function(values) { all(sapply(values[-1], function(x) isTRUE(all.equal(values[[1]], x)))) } 168 | } else if (is.character(check) && isTRUE(check == 'equivalent')) { 169 | check <- function(values) { all(sapply(values[-1], function(x) isTRUE(all.equal(values[[1]], x, check.attributes = F)))) } 170 | } else if (is.character(check) && isTRUE(check == 'identical')) { 171 | check <- function(values) { all(sapply(values[-1], function(x) identical(values[[1]], x))) } 172 | } 173 | ok <- check(values) 174 | 175 | if (!isTRUE(ok)) { 176 | stop("Input expressions are not equivalent.", call. = FALSE) 177 | } 178 | } 179 | 180 | ## GC first 181 | gc(FALSE) 182 | 183 | o <- if (control$order == "random") 184 | sample(rep(seq_along(exprs), times=times)) 185 | else if (control$order == "inorder") 186 | rep(seq_along(exprs), times=times) 187 | else if (control$order == "block") 188 | rep(seq_along(exprs), each=times) 189 | else 190 | stop("Unknown ordering. Must be one of 'random', 'inorder' or 'block'.") 191 | exprs <- exprs[o] 192 | 193 | if (anyDuplicated(nm) > 0) { 194 | duplicates <- nm[duplicated(nm)] 195 | stop("Expression names must be unique. Duplicate expression names: ", 196 | paste(duplicates, collapse = ", ")) 197 | } 198 | expr <- factor(nm[o], levels = nm) 199 | res <- .Call(do_microtiming, exprs, env, 200 | as.integer(control$warmup), setup, 201 | PACKAGE="microbenchmark") 202 | 203 | ## Sanity check. Fail as early as possible if the results are 204 | ## rubbish. 205 | if (all(is.na(res))) 206 | .all_na_stop() 207 | 208 | res <- data.frame(expr = expr, time=res) 209 | class(res) <- c("microbenchmark", class(res)) 210 | if (!is.null(unit)) 211 | attr(res, "unit") <- unit 212 | res 213 | } 214 | -------------------------------------------------------------------------------- /do: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env Rscript 2 | 3 | ## NOTE: We do not load all required packages upfront because most 4 | ## commands only require a subset or no extra packages at all and loading 5 | ## packages is expensive. So in the interest of fast startup, they are 6 | ## loaded on demand by the respective functions. 7 | 8 | SELFUPGRADE_URL <- "https://raw.githubusercontent.com/olafmersmann/do-r/master/do" 9 | 10 | catf <- function(fmt, ...) cat(sprintf(fmt, ...)) 11 | messagef <- function(fmt, ...) message(sprintf(fmt, ...)) 12 | 13 | die <- function(status, fmt, ...) { 14 | if (!missing(fmt)) 15 | messagef(paste0("ERROR: ", fmt), ...) 16 | quit(save="no", status=status) 17 | } 18 | 19 | parse_arguments <- function(arguments) { 20 | res <- list() 21 | equal_pos <- regexpr("=", arguments, fixed=TRUE) 22 | keys <- substr(arguments, 1, equal_pos-1) 23 | keys <- gsub('-', '_', keys, fixed=TRUE) 24 | 25 | values <- substr(arguments, equal_pos + 1, nchar(arguments)) 26 | res <- as.list(values) 27 | names(res) <- keys 28 | res 29 | } 30 | 31 | help_line <- function(commandline, helptext) { 32 | messagef(" ./do %s", commandline) 33 | messagef(paste(strwrap(helptext, indent=6, exdent=6), collapse="\n")) 34 | } 35 | 36 | package_name <- function() { 37 | read.dcf("./DESCRIPTION", "Package")[1] 38 | } 39 | 40 | get_version_from_git <- function() { 41 | tag <- system2("git", c("describe", "--tags", "--match", "v*"), 42 | stdout=TRUE, stderr=TRUE) 43 | 44 | ## Ignoring changes in whitespace is critical. Roxygen may have changed the 45 | ## spacing in the regenerated manual pages and esp. in the DESCRIPTION file 46 | ## because the y pretty print it compared to what write.dcf does. 47 | clean_args <- c("diff-index", "--ignore-space-change", "--quiet", tag) 48 | is_clean <- system2("git", clean_args) == 0 49 | version <- sub("v", "", tag, fixed=TRUE) 50 | 51 | ## Reformat version number by chopping of the hash at the end and 52 | ## appending an appropriate suffix if the tree is dirty. 53 | version_parts <- strsplit(version, "-")[[1]] 54 | version <- if (length(version_parts) == 2) { 55 | if (is_clean) { 56 | paste(version_parts, collapse="-") 57 | } else { 58 | paste0(paste(version_parts, collapse="-"), ".1") 59 | } 60 | } else if (length(version_parts) == 4) { 61 | revision <- if (is_clean) { 62 | version_parts[3] 63 | } else { 64 | revision <- as.integer(version_parts[3]) + 1 65 | } 66 | paste(paste(version_parts[1:2], collapse="-"), revision, sep=".") 67 | } 68 | version 69 | } 70 | 71 | do_build <- function(...) { 72 | library("devtools", warn.conflicts=FALSE) 73 | args <- list(...) 74 | if (length(args) > 0) { 75 | if (args[[1]] != "help") { 76 | messagef("ERROR: Invalid subcommand '%s' given.", args[[1]]) 77 | } 78 | help_line("build", "Build a source package.") 79 | return(invisible()) 80 | } 81 | do_update("all") 82 | message("INFO: Building package.") 83 | if (!file.exists("dist")) 84 | dir.create("dist") 85 | fn <- build(".", path="dist", quiet=TRUE) 86 | messagef("INFO: Package source tarball '%s' created.", fn) 87 | invisible(fn) 88 | } 89 | 90 | do_check <- function(subcommand, ...) { 91 | if (missing(subcommand)) 92 | subcommand <- "package" 93 | if (subcommand == "help" || ! subcommand %in% c("package", "spelling")) { 94 | help_line("check (package)", "Run R CMD check on package.") 95 | help_line("check spelling", "Check spelling of man pages.") 96 | return(invisible()) 97 | } 98 | 99 | if (subcommand == "package") { 100 | library("devtools", warn.conflicts=FALSE) 101 | do_update("all") 102 | check_dir <- format(Sys.time(), "check-%Y%m%d_%H%M%S") 103 | check_log <- file.path(check_dir, paste0(package_name(), ".Rcheck"), 104 | "00check.log") 105 | dir.create(check_dir) 106 | message("INFO: Checking package.") 107 | ok <- tryCatch(check(".", document=FALSE, quiet=TRUE, cleanup=FALSE, 108 | check_dir=check_dir), 109 | error = function(e) FALSE) 110 | 111 | if (ok) { 112 | ## Read check log lines 113 | lines <- readLines(check_log) 114 | ## Find all lines containing stuff we know is OK or irrelevant 115 | irrelevant_indexes <- c(grep("^\\* using", lines), 116 | grep("OK$", lines), 117 | grep("^\\* this is package .* version .*$", lines) 118 | ) 119 | relevant_lines <- lines[-irrelevant_indexes] 120 | ## Output all relevant lines 121 | if (length(relevant_lines) > 0) { 122 | message("INFO: Found the following anomalies in the log:") 123 | message(paste(" ", relevant_lines, collapse="\n")) 124 | } 125 | ## Remove cruft 126 | unlink(check_dir, recursive=TRUE) 127 | message("INFO: Package passed R CMD check.") 128 | } else { 129 | messagef("ERROR: Check failed. See '%s' for details.", check_log) 130 | ## If someone is sitting at the console, display the check logfile. 131 | if (isatty(stdout())) 132 | file.show(check_log) 133 | } 134 | } else if (subcommand == "spelling") { 135 | dictionaries <- "en_stats.rds" 136 | if (file.exists("./.dict.rds")) 137 | dictionaries <- c(dictionaries, "./.dict.rds") 138 | 139 | do_update("man") 140 | aspell(Sys.glob("man/*.Rd"), filter="Rd", 141 | dictionaries=dictionaries) 142 | } 143 | } 144 | 145 | do_clean <- function(...) { 146 | l <- list(...) 147 | if (length(l) > 0 && l[[1]] == "help") { 148 | help_line("clean", "Remove cruft from 'src/' directory.") 149 | return(invisible()) 150 | } 151 | 152 | ## Compiled code 153 | ofiles <- c(list.files("src", pattern=".*\\.o$", full.names=TRUE), 154 | list.files("src", pattern=".*\\.so$", full.names=TRUE), 155 | list.files("src", pattern=".*\\.dll$", full.names=TRUE)) 156 | if (length(ofiles) > 0) { 157 | unlink(ofiles) 158 | messagef("INFO: Removed object files (%s).", 159 | paste0("'", ofiles, "'", collapse=", ")) 160 | } 161 | } 162 | 163 | do_help <- function(cmd, ...) { 164 | message("Usage:") 165 | if (missing(cmd) || cmd == "all") { 166 | for (thing in sort(ls(.GlobalEnv))) { 167 | if (thing != "do_help" && regexpr("^do_.*", thing) > 0) { 168 | if (exists(thing, mode="function")) { 169 | command <- get(thing, mode="function") 170 | command("help") 171 | } 172 | } 173 | } 174 | } else { 175 | command_name <- paste0("do_", cmd) 176 | if (exists(command_name, mode="function")) { 177 | command <- get(command_name, mode="function") 178 | message("Usage:") 179 | command("help") 180 | } else { 181 | messagef("ERROR: Unknown subcommand '%s'. No help available.'", 182 | command_name) 183 | } 184 | } 185 | } 186 | 187 | do_update <- function(subcommand, ...) { 188 | if (missing(subcommand)) 189 | subcommand <- "help" 190 | 191 | if (subcommand == "help") { 192 | help_line("update collate", "Update collation order of files.") 193 | help_line("update man", "Update manual pages using Roxygen2.") 194 | help_line("update namespace", 195 | "Update NAMESPACE file using Roxygen2.") 196 | help_line("update version", 197 | "Update version field in DESCRIPTION based on SCM.") 198 | help_line("update all", "All of the above.") 199 | } else if (subcommand == "man") { 200 | library("roxygen2", warn.conflicts=FALSE) 201 | message("INFO: Updating manual pages") 202 | capture.output(roxygenize(".", roclets="rd", clean=TRUE)) 203 | } else if (subcommand == "version") { 204 | version <- get_version_from_git() 205 | message("INFO: Setting version to ", version) 206 | desc <- read.dcf("DESCRIPTION") 207 | desc[,"Version"] <- version 208 | write.dcf(desc, file="DESCRIPTION") 209 | } else if (subcommand == "namespace") { 210 | library("roxygen2", warn.conflicts=FALSE) 211 | message("INFO: Updating NAMESPACE file") 212 | capture.output(roxygenize(".", roclets="namespace", clean=TRUE)) 213 | } else if (subcommand == "all") { 214 | do_update("namespace") 215 | do_update("man") 216 | do_update("version") 217 | } 218 | } 219 | 220 | do_selfupgrade <- function(...) { 221 | args <- list(...) 222 | if (length(args) > 0 && args[[1]] == "help") { 223 | help_line("selfupgrade", "Replace do script with latest version from public repository. Note: This will unconditionally overwrite any changes you may have made to the do script.") 224 | return(invisible()) 225 | } 226 | if (file.exists("do.tmp")) 227 | die(100, "File 'do.tmp' from previous selfupgrade attempt exists. Please remove it and retry.") 228 | 229 | download.file(SELFUPGRADE_URL, "do.tmp", method="curl") 230 | if (file.exists("do.tmp")) { 231 | ## Check that we can parse the script. 232 | ok <- tryCatch({ 233 | parse("do.tmp") 234 | TRUE 235 | }, error=function(e) FALSE) 236 | if (ok) { 237 | file.rename("do.tmp", "do") 238 | ## Avoid user modifications by only setting read and execute bits on do 239 | Sys.chmod("do", mode="0555", use_umask=FALSE) 240 | } else { 241 | die(100, "The new do script (file 'do.tmp') appears to be corrupt. Please investigate!") 242 | } 243 | } else { 244 | die(100, "Failed to download new do script to file 'do.tmp'.") 245 | } 246 | } 247 | 248 | do_drat <- function(subcommand, ...) { 249 | if (missing(subcommand)) 250 | subcommand <- "help" 251 | 252 | if (subcommand == "help") { 253 | help_line("drat publish", "Publish package to drat repository.") 254 | } else if (subcommand == "publish") { 255 | library("drat", warn.conflicts=FALSE) 256 | fn <- do_build() 257 | insertPackage(fn, "../drat", commit=TRUE) 258 | message("INFO: Source package published to drat repository '../drat'.") 259 | } 260 | } 261 | 262 | main <- function(cmd, ...) { 263 | if (missing(cmd)) 264 | cmd = "help" 265 | command_name <- paste0("do_", cmd) 266 | if (exists(command_name, mode="function")) { 267 | command <- get(command_name, mode="function") 268 | command(...) 269 | } else { 270 | messagef("ERROR: Unknown command '%s' given.", cmd) 271 | do_help() 272 | } 273 | } 274 | 275 | if (interactive()) { 276 | message("WARN: 'do' is not ment to be used interactively! Consider using devtools instead.") 277 | } else { 278 | args <- parse_arguments(commandArgs(TRUE)) 279 | do.call(main, args) 280 | } 281 | 282 | # vim: filetype=r 283 | --------------------------------------------------------------------------------