timings.Rmd

---
title: "timings"
output: github_document
---

For details please see these articles:

  * [Using a Column as a Column Index](http://www.win-vector.com/blog/2018/09/using-a-column-as-a-column-index/)
  * [Timing Column Indexing in R](http://www.win-vector.com/blog/2018/09/timing-column-indexing-in-r/)
  

```{r setup}
library("microbenchmark")
library("dplyr")
library("dtplyr")
library("tidyr")
library("purrr")
library("wrapr")
library("data.table")
library("rqdatatable")
library("ggplot2")
library("WVPlots")
```

```{r data}
mk_data <- function(n) {
  data.frame(x = seq_len(n) + 0.0,
             y = seq_len(n) + n + 0.0,
             choice = rep(c("x", "y"), ceiling(n/2))[1:n],
             stringsAsFactors = FALSE)
}

```


```{r definefns}

base_R_sapply <- function(df) {
  # https://community.rstudio.com/t/extracting-value-from-a-data-frame-where-column-name-to-extract-from-is-dynamically-determined-by-values-in-another-column/14585
  df$derived <- sapply( 
    seq_len(nrow(df)), 
    function(i) { 
      df[i, df$choice[[i]], drop = TRUE ]
    })
  df
}

base_R_matrix_index_match <- function(df) {
  # https://community.rstudio.com/t/extracting-value-from-a-data-frame-where-column-name-to-extract-from-is-dynamically-determined-by-values-in-another-column/14585
  dtmp <- df[, 
             intersect(df$choice, colnames(df)), 
             drop = FALSE]
  df$derived <- dtmp[
    cbind(seq_len(nrow(df)),
          match(df$choice, colnames(dtmp)))]
  df
}

base_R_matrix_index_map <- function(df) {
  # https://community.rstudio.com/t/extracting-value-from-a-data-frame-where-column-name-to-extract-from-is-dynamically-determined-by-values-in-another-column/14585
  dtmp <- df[, 
             intersect(df$choice, colnames(df)), 
             drop = FALSE]
  cmap <- seq_len(length(colnames(df)))
  names(cmap) <- colnames(df)
  df$derived <- dtmp[
    cbind(seq_len(nrow(df)),
          cmap[df$choice])]
  df
}

base_R_split_apply <- function(df) {
  df$id = seq_len(nrow(df))
  dfl = split(df, df$choice)
  dfl = lapply(dfl,
               function(dfli) {
                 pick = dfli$choice[[1]]
                 dfli$derived = dfli[[pick]]
                 dfli
               })
  df = do.call(rbind, dfl)
  df = df[order(df$id), , drop=FALSE]
  df$id <- NULL
  df
}

base_R_get0 <- function(df) {
  # http://www.win-vector.com/blog/2018/09/using-a-column-as-a-column-index/#comment-67008
  df$derived <-
    do.call(mapply,c(df,FUN = function(...)
      with(list(...),
           get0(choice,ifnotfound = NA, inherits = FALSE))))
  df
}

purrr_get0 <- function(df) {
  # http://www.win-vector.com/blog/2018/09/using-a-column-as-a-column-index/#comment-67007
  df$derived <-
    pmap_dbl(df, ~with(list(...), get0(choice, ifnotfound = NA,inherits = FALSE)))
  df
}

data.table_SD_method <- function(df) {
  # https://community.rstudio.com/t/extracting-value-from-a-data-frame-where-column-name-to-extract-from-is-dynamically-determined-by-values-in-another-column/14585
  dt <- as.data.table(df)
  dt[, derived := .SD[[choice]], by = choice][]
}

data.table_I_method <- function(df) {
  # https://community.rstudio.com/t/extracting-value-from-a-data-frame-where-column-name-to-extract-from-is-dynamically-determined-by-values-in-another-column/14585
  dt <- as.data.table(df)
  dt[, derived := dt[[choice]][.I], by=choice][]
}


dplyr_choice_gather <- function(df) {
  # https://community.rstudio.com/t/extracting-value-from-a-data-frame-where-column-name-to-extract-from-is-dynamically-determined-by-values-in-another-column/14585
  df <- df %>%
    mutate(id = seq_len(nrow(.)))
  df %>%
    gather("column", "derived", -id, -choice) %>%
    filter(column == choice) %>%
    select(-choice, -column) %>%
    right_join(df, by = "id") %>%
    select(-id)
}

dplyr_group_assign <- function(df) {
  # http://www.win-vector.com/blog/2018/09/using-a-column-as-a-column-index/
  df %>% 
    group_by(choice) %>%
    mutate(derived = .data[[ choice[[1]] ]]) %>%
    ungroup() 
}

dtplyr_group_assign <- function(df) {
  # http://www.win-vector.com/blog/2018/09/using-a-column-as-a-column-index/
  dt <- as.data.table(df)
  dt %>% 
    group_by(choice) %>%
    mutate(derived = .data[[ choice[[1]] ]]) %>%
    ungroup() 
}


dplyr_rowwise_parse <- function(df) {
  # http://www.win-vector.com/blog/2018/09/using-a-column-as-a-column-index/#comment-67006
  df %>%
    rowwise() %>% 
    mutate(derived = eval(parse(text = choice))) %>%
    ungroup()
}


dplyr_rowwise_index <- function(df) {
  df %>%
    rowwise() %>% 
    mutate(derived = .data[[choice]]) %>%
    ungroup()
}

rqdatatable_direct <- make_dt_lookup_by_column("choice", "derived")
```

```{r check, error = TRUE}
df <- mk_data(3)

base_R_sapply(df)

base_R_matrix_index_match(df)

base_R_matrix_index_map(df)

base_R_split_apply(df)

base_R_get0(df)

data.table_SD_method(df)

data.table_I_method(df)

dplyr_choice_gather(df)

dplyr_group_assign(df)

dplyr_rowwise_parse(df)

dplyr_rowwise_index(df)

purrr_get0(df)

lookup_by_column(df, "choice", "derived")

lookup_by_column(df, "choice", "derived",
                 f_dt_factory = make_dt_lookup_by_column)

rqdatatable_direct(df)

dtplyr_group_assign(df)
```


```{r time}
df <- mk_data(1000000)

timings <- microbenchmark(
  base_R_sapply = base_R_sapply(df),
  base_R_matrix_index_match = base_R_matrix_index_match(df),
  base_R_matrix_index_map = base_R_matrix_index_map(df),
  base_R_split_apply = base_R_split_apply(df),
  base_R_get0 = base_R_get0(df),
  data.table_SD_method = data.table_SD_method(df),
  data.table_I_method = data.table_I_method(df),
  dplyr_choice_gather = dplyr_choice_gather(df),
  dplyr_group_assign = dplyr_group_assign(df),
  dplyr_rowwise_parse = dplyr_rowwise_parse(df),
  dplyr_rowwise_index = dplyr_rowwise_index(df),
  purrr_get0 = purrr_get0(df),
  rqdatatable_base = lookup_by_column(df, "choice", "derived"),
  rqdatatable_data.table = lookup_by_column(df, "choice", "derived",
                                            f_dt_factory = make_dt_lookup_by_column),
  rqdatatable_direct = rqdatatable_direct(df),
  unit = 's',
  times = 10L
)
saveRDS(timings, file = "timings.RDS")
```


```{r present}
tdf <- as.data.frame(timings)


tdf$seconds <- tdf$time/1e+9
tdf$method <- factor(as.character(tdf$expr),
                     rev(levels(tdf$expr)))

method_family <- qc(
  base_R_sapply = base_R,
  base_R_matrix_index_match = base_R,
  base_R_matrix_index_map = base_R,
  base_R_split_apply = base_R,
  base_R_get0 = base_R,
  purrr_get0 = tidyverse,
  data.table_SD_method = data.table,
  data.table_I_method = data.table,
  dplyr_choice_gather = tidyverse,
  dplyr_group_assign = tidyverse,
  dplyr_rowwise_parse = tidyverse,
  dplyr_rowwise_index = tidyverse,
  rqdatatable_base = base_R,
  rqdatatable_data.table = data.table,
  rqdatatable_direct = data.table
)

tdf$method_family <- method_family[as.character(tdf$method)]

tdf %.>%
  project_nse(., 
              groupby = "method",
              mean_seconds = mean(seconds)) %.>%
  orderby(., "mean_seconds")

WVPlots::ScatterBoxPlotH(tdf, "seconds","method",  
                         title="Runtime by Method") +
  facet_wrap(~method_family, ncol = 1, drop = TRUE, scales = "free_y") +
  geom_hline(yintercept = 1, color = "red", linetype = 2) + 
  xlab(NULL)

WVPlots::ScatterBoxPlotH(tdf, "seconds","method",  
                         title="Runtime by Method, log-scale") + 
  scale_y_log10() +
  facet_wrap(~method_family, ncol = 1, drop = TRUE, scales = "free_y") +
  geom_hline(yintercept = 1, color = "red", linetype = 2) + 
  xlab(NULL)
```