Permalink
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
178 lines (158 sloc) 5.2 KB
#' ---
#' title: "Turn data frame into a list, one component per row"
#' author: "Jenny Bryan, updating work of Winston Chang"
#' date: "`r format(Sys.Date())`"
#' output: github_document
#' ---
#'
#' Update of <https://rpubs.com/wch/200398>.
#'
#' * Added some methods, removed some methods.
#' * Run every combination of problem size & method multiple times.
#' * Explore different number of rows and columns, with mixed col types.
library(scales)
library(tidyverse)
# for loop over row index
f_for_loop <- function(df) {
out <- vector(mode = "list", length = nrow(df))
for (i in seq_along(out)) {
out[[i]] <- as.list(df[i, , drop = FALSE])
}
out
}
# split into single row data frames then + lapply
f_split_lapply <- function(df) {
df <- split(df, seq_len(nrow(df)))
lapply(df, function(row) as.list(row))
}
# lapply over the vector of row numbers
f_lapply_row <- function(df) {
lapply(seq_len(nrow(df)), function(i) as.list(df[i, , drop = FALSE]))
}
# purrr::pmap
f_pmap <- function(df) {
pmap(df, list)
}
# purrr::transpose (happens to be exactly what's needed here)
f_transpose <- function(df) {
transpose(df)
}
## explicit gc, then execute `expr` `n` times w/o explicit gc, return timings
benchmark <- function(n = 1, expr, envir = parent.frame()) {
expr <- substitute(expr)
gc()
map(seq_len(n), ~ system.time(eval(expr, envir), gcFirst = FALSE))
}
run_row_benchmark <- function(nrow, times = 5) {
df <- data.frame(
x = rep_len(letters, length.out = nrow),
y = runif(nrow),
z = seq_len(nrow)
)
res <- list(
transpose = benchmark(times, f_transpose(df)),
pmap = benchmark(times, f_pmap(df)),
split_lapply = benchmark(times, f_split_lapply(df)),
lapply_row = benchmark(times, f_lapply_row(df)),
for_loop = benchmark(times, f_for_loop(df))
)
res <- map(res, ~ map_dbl(.x, "elapsed"))
tibble(
nrow = nrow,
method = rep(names(res), lengths(res)),
time = flatten_dbl(res)
)
}
run_col_benchmark <- function(ncol, times = 5) {
nrow <- 3
template <- data.frame(
x = letters[seq_len(nrow)],
y = runif(nrow),
z = seq_len(nrow)
)
df <- template[rep_len(seq_len(ncol(template)), length.out = ncol)]
res <- list(
transpose = benchmark(times, f_transpose(df)),
pmap = benchmark(times, f_pmap(df)),
split_lapply = benchmark(times, f_split_lapply(df)),
lapply_row = benchmark(times, f_lapply_row(df)),
for_loop = benchmark(times, f_for_loop(df))
)
res <- map(res, ~ map_dbl(.x, "elapsed"))
tibble(
ncol = ncol,
method = rep(names(res), lengths(res)),
time = flatten_dbl(res)
)
}
## force figs to present methods in order of time
flevels <- function(df) {
mutate(df, method = fct_reorder(method, .x = desc(time)))
}
plot_it <- function(df, what = "nrow") {
log10_breaks <- trans_breaks("log10", function(x) 10 ^ x)
log10_mbreaks <- function(x) {
limits <- c(floor(log10(x[1])), ceiling(log10(x[2])))
breaks <- 10 ^ seq(limits[1], limits[2])
unlist(lapply(breaks, function(x) x * seq(0.1, 0.9, by = 0.1)))
}
log10_labels <- trans_format("log10", math_format(10 ^ .x))
ggplot(
df %>% dplyr::filter(time > 0),
aes_string(x = what, y = "time", colour = "method")
) +
geom_point() +
stat_summary(aes(group = method), fun.y = mean, geom = "line") +
scale_y_log10(
breaks = log10_breaks, labels = log10_labels, minor_breaks = log10_mbreaks
) +
scale_x_log10(
breaks = log10_breaks, labels = log10_labels, minor_breaks = log10_mbreaks
) +
labs(
x = paste0("Number of ", if (what == "nrow") "rows" else "columns"),
y = "Time (s)"
) +
theme_bw() +
theme(aspect.ratio = 1, legend.justification = "top")
}
## dry runs
# df_test <- run_row_benchmark(nrow = 10000) %>% flevels()
# df_test <- run_col_benchmark(ncol = 10000) %>% flevels()
# ggplot(df_test, aes(x = method, y = time)) +
# geom_jitter(width = 0.25, height = 0) +
# scale_y_log10()
## The Real Thing
## fairly fast up to 10^4, go get a coffee at 10^5 (row case only)
#df_r <- map_df(10 ^ (1:5), run_row_benchmark) %>% flevels()
#write_csv(df_r, "row-benchmark.csv")
df_r <- read_csv("row-benchmark.csv") %>% flevels()
#+ row-benchmark
plot_it(df_r, "nrow")
#ggsave("row-benchmark.png")
#df_c <- map_df(10 ^ (1:5), run_col_benchmark) %>% flevels()
#write_csv(df_c, "col-benchmark.csv")
df_c <- read_csv("col-benchmark.csv") %>% flevels()
#+ col-benchmark
plot_it(df_c, "ncol")
#ggsave("col-benchmark.png")
## used at first, but saw same dramatic gc artefacts as described here
## in my plots
## https://radfordneal.wordpress.com/2014/02/02/inaccurate-results-from-microbenchmark/
## went for a DIY solution where I control gc
# library(microbenchmark)
# run_row_microbenchmark <- function(nrow, times = 5) {
# df <- data.frame(x = rnorm(nrow), y = runif(nrow), z = runif(nrow))
# microbenchmark(
# for_loop = f_for_loop(df),
# split_lapply = f_split_lapply(df),
# lapply_row = f_lapply_row(df),
# pmap = f_pmap(df),
# transpose = f_transpose(df),
# times = times
# ) %>%
# as_tibble() %>%
# rename(method = expr) %>%
# mutate(method = as.character(method)) %>%
# add_column(nrow = nrow, .before = 1)
# }