Merge pull request #66 from tdhock/simple-example

sparse m vignette

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: atime
 Type: Package
 Title: Asymptotic Timing
-Version: 2024.10.5
+Version: 2024.11.5
 Authors@R: c(
     person("Toby", "Hocking",
      email="toby.hocking@r-project.org",
@@ -37,5 +37,7 @@ Suggests:
     dplyr,
     tidyr,
     nc,
-    RColorBrewer
+    RColorBrewer,
+    tibble,
+    Matrix
 VignetteBuilder: knitr

NEWS

@@ -1,3 +1,11 @@
+Changes in version 2024.11.5
+
+- new feature: atime_grid() stores a data table of parameters that were specified as input, with corresponding new column names in
+- atime() measurements table,
+- references_best() measurements and plot.references tables,
+- predict() tables: measurements and predictions tables.
+- new sparse vignette which shows how to make a custom plot with facets defined by variables that were used in atime_grid().
+
 Changes in version 2024.10.5
 
 - bugfix: atime_test again outputs historical versions which were specified in ...

R/atime.R

@@ -67,18 +67,25 @@ atime_grid <- function
     nrow(value.mat), ncol(value.mat))
   name.value.vec <- apply(name.value.mat, 1, paste, collapse=collapse)
   out.list <- list()
+  out.param.list <- list()
   for(expr.name in names(elist)){
     for(row.i in 1:nrow(param.dt)){
       param.name.value <- name.value.vec[[row.i]]
       out.name <- paste0(expr.name, expr.param.sep, param.name.value)
-      param.row.list <- as.list(param.dt[row.i])
+      param.row <- param.dt[row.i]
+      param.row.list <- as.list(param.row)
       param.row.list[symbol.params] <- lapply(
         param.row.list[symbol.params], as.symbol)
       out.list[[out.name]] <- eval(substitute(
         substitute(EXPR, param.row.list), 
         list(EXPR=elist[[expr.name]])))
+      out.param.list[[paste(expr.name, row.i)]] <- data.table(
+        expr.name=out.name,
+        expr.grid=expr.name,
+        param.row)
     }
   }
+  attr(out.list, "parameters") <- rbindlist(out.param.list)
   out.list
 }
 
@@ -190,6 +197,12 @@ atime <- function(N=default_N(), setup, expr.list=NULL, times=10, seconds.limit=
     seconds="median",
     more.units)
   measurements <- rbindlist(metric.dt.list)
+  expr.list.params <- attr(expr.list,"parameters")
+  by.vec <- "expr.name"
+  if(is.data.table(expr.list.params)){
+    measurements <- expr.list.params[measurements, on="expr.name"]
+    by.vec <- names(expr.list.params)
+  }
   only.one <- measurements[, .(sizes=.N), by=expr.name][sizes==1]
   if(nrow(only.one)){
     warning("please increase max N or seconds.limit, because only one N was evaluated for expr.name: ", paste(only.one[["expr.name"]], collapse=", "))
@@ -198,7 +211,8 @@ atime <- function(N=default_N(), setup, expr.list=NULL, times=10, seconds.limit=
     list(
       unit.col.vec=unit.col.vec,
       seconds.limit=seconds.limit,
-      measurements=measurements),
+      measurements=measurements,
+      by.vec=by.vec),
     class="atime")
 }
 

R/predict.R

@@ -43,7 +43,7 @@ predict.references_best <- function(object, ...){
           unit.value,
           N=10^approx(log10.empirical, log10.N, log10(unit.value))$y)]
       }
-    }, by=expr.name]
+    }, by=c(object$by.vec)]
     not.NA <- pred.dt[!is.na(N)]
     if(nrow(not.NA)==0){
       stop(unit, "=", unit.value, " is outside range of data, please change to a value that intersects at least one of the empirical curves")

R/references.R

@@ -78,21 +78,21 @@ references_best <- function(L, fun.list=NULL){
       all.refs <- DT[
         ,
         references(N, .SD[[col.name]], lower.limit, fun.list),
-        by=expr.name]
-      all.refs[, rank := rank(-N), by=.(expr.name, fun.name)]
+        by=c(L$by.vec)]
+      all.refs[, rank := rank(-N), by=c(L$by.vec, "fun.name")]
       second <- all.refs[rank==2]
       second[, dist := log10(empirical/reference) ]
       second[, sign := sign(dist)]
-      l.cols <- list(overall="expr.name", each.sign=c("expr.name","sign"))
+      l.cols <- list(overall=L$by.vec, each.sign=c(L$by.vec,"sign"))
       for(best.type in names(l.cols)){
         by <- l.cols[[best.type]]
         second[
         , paste0(best.type,".rank") := rank(abs(dist))
-        , by=by]
+        , by=c(by)]
       }
       ref.dt.list[[unit]] <- data.table(unit, all.refs[
         second,
-        on=.(expr.name, fun.name, fun.latex)])
+        on=c(L$by.vec, "fun.name", "fun.latex")])
       best <- second[overall.rank==1, .(expr.name, fun.name, fun.latex)]
       metric.dt.list[[unit]] <- data.table(unit, best[
         DT, on=.(expr.name)
@@ -108,7 +108,8 @@ references_best <- function(L, fun.list=NULL){
     seconds.limit=L[["seconds.limit"]],
     references=ref.dt,
     plot.references=ref.dt[each.sign.rank==1],
-    measurements=do.call(rbind, metric.dt.list)),
+    measurements=do.call(rbind, metric.dt.list),
+    by.vec=L[["by.vec"]]),
     class="references_best")
 }
 
@@ -133,17 +134,17 @@ plot.references_best <- function(x, ...){
     }
     gg <- gg+
       ggplot2::geom_ribbon(ggplot2::aes(
-        N, ymin=min, ymax=max),
+        N, ymin=min, ymax=max, group=expr.name),
         data=meas[unit=="seconds"],
         fill=emp.color,
         alpha=0.5)+
       ggplot2::geom_line(ggplot2::aes(
-        N, empirical),
+        N, empirical, group=expr.name),
         size=2,
         color=emp.color,
         data=meas)+
       ggplot2::geom_line(ggplot2::aes(
-        N, reference, group=fun.name),
+        N, reference, group=paste(expr.name, fun.name)),
         color=ref.color,
         size=1,
         data=ref.dt)+

tests/testthat/test-CRAN.R

@@ -167,7 +167,15 @@ test_that("atime_grid symbol.params arg OK", {
   ),
   foo=FUN(regex, text, proto, perl = PERL),
   symbol.params="FUN")
-  expect_identical(grid.result, list("foo PERL=TRUE,FUN=strcapture"=quote(strcapture(regex, text, proto, perl=TRUE))))
+  expected <- list(
+    "foo PERL=TRUE,FUN=strcapture"=quote(
+      strcapture(regex, text, proto, perl=TRUE)))
+  attr(expected,"parameters") <- data.table(
+    expr.name="foo PERL=TRUE,FUN=strcapture",
+    expr.grid="foo",
+    PERL=TRUE,
+    FUN="strcapture")
+  expect_identical(grid.result, expected)
 })
 
 test_that("atime_grid error for list of funs", {
@@ -429,3 +437,52 @@ test_that("atime_test outputs historical versions", {
     Fast = "ed72e398df76a0fcfd134a4ad92356690e4210ea") # Merge commit of the PR (https://github.com/Rdatatable/data.table/pull/5054) that fixes the issue
   expect_identical(names(atest), c("setup", "expr", "Slow", "Fast"))
 })
+
+test_that("atime_grid parameters attribute", {
+  library(Matrix)
+  param.list <- list(
+    non_zeros=c("N","N^2/10"),
+    fun=c("matrix","Matrix")
+  )
+  (expr.list <- atime::atime_grid(
+    param.list,
+    mult_vector={
+      L[[fun]][[non_zeros]]%*%w
+      data.frame(in_size=N)
+    },
+    add_one={
+      L[[fun]][[non_zeros]]+1
+      data.frame(in_size=N)
+    },
+    collapse="\n"))
+  expected.names <- c("expr.name","expr.grid","non_zeros", "fun")
+  expect_identical(names(attr(expr.list,"parameters")), expected.names)
+  mult.result <- atime::atime(
+    N=as.integer(10^seq(1,2,by=0.25)),
+    setup={
+      L <- list()
+      set.seed(1)
+      w <- rnorm(N)
+      for(non_zeros in param.list$non_zeros){
+        N.not.zero <- as.integer(eval(str2lang(non_zeros)))
+        m <- matrix(0, N, N)
+        m[sample(N^2, N.not.zero)] <- rnorm(N.not.zero)
+        for(fun in param.list$fun){
+          L[[fun]][[non_zeros]] <- get(fun)(as.numeric(m), N, N)
+        }
+      }
+    },
+    foo={
+      w+1
+      data.frame(in_size=N)
+    },
+    result=TRUE,
+    expr.list=expr.list)
+  expect_in(expected.names, names(mult.result$measurements))
+  mult.refs <- atime::references_best(mult.result)
+  expect_in(expected.names, names(mult.refs$measurements))
+  expect_in(expected.names, names(mult.refs$plot.references))
+  mult.pred <- predict(mult.refs, in_size=50)
+  expect_in(expected.names, names(mult.pred$measurements))
+  expect_in(expected.names, names(mult.pred$prediction))
+})