rkingdc

run_benchmark <- function(nrows, ncuts, db, times=100, add_index=FALSE){

    ## setup ##
    d <- data.frame(column_to_cut = sample.int(10000, nrows, replace=TRUE),
                    id = seq(nrows),
                    k_dummy = 1)
    # can't add indexes to temporary tables
    dbWriteTable(db, 'data', d, overwrite=TRUE, temporary=!add_index)

    # for testing how indexes affect performance

rkingdc

.make_db_rquery_join_fn <- function(data, tbl_cuts, db=db, column_to_cut = 'column_to_cut'){
    # test rquery connection options
    dbopts <- rquery::rq_connection_tests(db)

    # create rquery option connection
    rqdb <- rquery::rquery_db_info(connection = db,
                                  is_dbi = TRUE,
                                  connection_options = dbopts)

rkingdc

.make_db_rquery_join_fn <- function(data, tbl_cuts, db=db, column_to_cut = 'column_to_cut'){
    # test rquery connection options
    dbopts <- rquery::rq_connection_tests(db)

    # create rquery option connection
    rqdb <- rquery::rquery_db_info(connection = db,
                                  is_dbi = TRUE,
                                  connection_options = dbopts)

rkingdc

db_dplyr_join_fn <- function(data, tbl_cuts, column_to_cut="column_to_cut"){
  bin_choices <- data %>%
    select(., id, k_dummy, !!rlang::sym(column_to_cut)) %>%
    left_join(., tbl_cuts, by = 'k_dummy') %>%
    filter(., cut >= !!rlang::sym(column_to_cut)) %>%
    group_by(., id) %>%
    summarise(., cut_ = min(cut, na.rm = TRUE))
  return(dplyr::compute(dplyr::left_join(data, bin_choices, by = 'id')))
}

rkingdc

.make_case_when_fn <- function(column_name, cut_vector){
    # get names in various formats
    s_column_name     <- rlang::sym(column_name)

    # the vector shouldn't have names, but if it has them, use those names instead of the
    # canned ones then NULL out the names
    if (!is.null(names(cut_vector))){
        cut_names <- names(cut_vector)
        cut_vector <- unname(cut_vector)

rkingdc

db_dplyr_join_fn <- function(data, tbl_cuts, column_to_cut="column_to_cut"){
  bin_choices <- data %>%
    select(., id, k_dummy, !!rlang::sym(column_to_cut)) %>%
    left_join(., tbl_cuts, by = 'k_dummy') %>%
    filter(., cut >= !!rlang::sym(column_to_cut)) %>%
    group_by(., id) %>%
    summarise(., cut_ = min(cut, na.rm = TRUE)) 
  return(dplyr::compute(dplyr::left_join(data, bin_choices, by = 'id')))
}

rkingdc

# non https server re-direct server (in case R is pre 3.2.0) 
r <- 'http://cloud.r-project.org/'

# all required packages+ghit
pkgs <- c("shiny", "shinyAce", "shinyBS", "knitr", "car", "yaml", "nlme", 
					"lsmeans", "multcompView", 'ghit')
          
# install binary dependencies
install.packages(pkgs, repos = r)

rkingdc

myHistory <- readLines('.Rhistory') # read in your .Rhistory file

pkgs <- unlist(unique(regmatches(myHistory, gregexpr('(?<=(library\\()).*(?=\\))|(?<=(require\\()).*(?=\\))', myHistory, perl=TRUE)))) # find all packages used in that session
sapply(pkgs, library, character.only=TRUE) # packages need to be on the search path to list their functions, so load them all
pkgs <- paste0('package:', pkgs) # package names must be in this format for ls() to work
fxns <- unname(unlist(sapply(pkgs, ls))) # list all exported functions in all loaded packages

myHistory <- gsub('\\,', ' ', myHistory) # remove all commas because they mess up remove extra arguments from *apply
myHistory <- gsub('.*([msl(parl)]?apply).*(?<=\\,)(.*)?,.*\\).*', '\\1 \\2', myHistory, perl=TRUE) # for *apply functions, remove eveything but the *apply and the functions applied
myHistory <- gsub("(?=apply)([\\(]).*\\)", '', myHistory, perl=TRUE) # remove anything in between parentheses

rkingdc

#########################
### Download Data App ###
#########################
library(shiny)
library(WriteXLS)

measures <- c('Measure 1'='m1',
              'Measure 2'='m2',
              'Measure 3'='m3')