0_helpers.R

#' # Helper functions used throughout {.tabset .tabset-sticky}
#' documentation on the functions is interspersed through code comments
#'
#' ## set some options
#' dont show messages when loading libraries
library = function(...) suppressMessages(base::library(...))
#' never set strings as factors automatically (google for reason why)
options(stringsAsFactors = FALSE)
#' show four significant digits tops
options(digits = 4)
#' tend not to show scientific notation, because we're just psychologists
options(scipen = 7)
#' make output a bit wider
options(width = 110)
#' set a seed to make analyses depending on random number generation reproducible
set.seed(1710) # if you use your significant other's birthday make sure you stay together for the sake of reproducibility


#' ## Load packages
#' generate the site
library(rmarkdown)
#' set options for chunks
library(knitr)
#' my formr utility package to generate e.g. the bibliography
library(formr)
#' pretty-printed output
library(pander)
#' tidyverse date times
library(lubridate)
#' tidyverse strings
library(stringr)
#' extractor functions for models
library(broom)
#' grammar of graphics plots
library(ggplot2)
#' svg graphs
# library(svglite);
library(ggthemes)
library(codebook)

#' tidyverse: has a lot of naming conflicts, so always load last
library(tidyverse)

#' some packages may be needed without being loaded
fool_renv = function() {
  # needed to install formr package
  library(devtools)
  library(rmarkdown)
  library(Cairo)
  # needed to actually run rmarkdown in RStudio, but for some reason not in its dependencies
  library(formatR)
}

#' ## Output options
#' use pander to pretty-print objects (if possible)
opts_chunk$set(
  dev = "png"
)

#' don't split tables, scroll horizontally
panderOptions("table.split.table", Inf)

#' Set plot defaults
theme_set(theme_tufte(base_size = 20, base_family='Helvetica Neue'))


#' ## Spin R files
#' R scripts can be documented in markdown using Roxygen comments, as demonstrated here
#' This function turns all R files (that don't have an Rmd file of the same name and that don't start with an underscore _) into HTML pages
spin_R_files_to_site_html = function() {
  library(knitr)
  all_Rs = c(list.files(pattern = "^[^_].+\\.R$"), ".Rprofile")
  component_Rmds = list.files(pattern = "^_.+\\.Rmd$")
  temporary_Rmds = c()
  for (i in seq_along(all_Rs)) {
    if(all_Rs[i] == ".Rprofile") {
      Rmd_file = "Rprofile.Rmd"
    } else {
      Rmd_file = paste0(all_Rs[i], "md")
    }
    if (!file.exists(Rmd_file)) {
      temporary_Rmds[i] <- Rmd_file
      if(file.exists(all_Rs[i])) {
      temp_knit = spin(all_Rs[i], knit = FALSE, envir = new.env(), format = "Rmd")
      prepended_yaml = paste0(c(paste0("---
title: ",all_Rs[i],"
output:
  html_document:
    code_folding: 'show'
---

"), readLines(temp_knit)), collapse = "\n")
      unlink(temp_knit)
      cat(prepended_yaml, file = Rmd_file)
      }
    }
  }
  components_and_scripts = c(temporary_Rmds, component_Rmds)
  for (i in seq_along(components_and_scripts)) {
    opts_chunk$set(eval = FALSE, cache = FALSE)
    # if we call render_site on the .R file directly it adds a header I don't like
    rmarkdown::render_site(components_and_scripts[i], quiet = TRUE)
  }
  opts_chunk$set(eval = TRUE, cache = TRUE)
  unlink(temporary_Rmds)
}


#' ##### we use this function to automatically get nice tables
pander_handler = function(x, ...) {
  anyS3method = function(x) {
    classes = class(x)
    any(sapply(classes, FUN = function(classes) { !is.null(getS3method('pander',classes,TRUE)) } ))
  }
  if ("knit_asis" %in% class(x)) {
    x # obj is knit_asis already, don't touch it
    # (useful if e.g. pander is called with options in the doc)
  } else if (anyS3method(x)) {
    pander(x, row.names = F, ...) # if method available, pander
  } else if (isS4(x)) {
    show(x)
  } else {
    print(x)
  }
}





##### counting excluded participants

n_excluded = function(x) {
  excluded_new = sum(is.na(x) | x == FALSE,na.rm = T)
  if (is.null(excluded_old)) {
    excluded = excluded_new
  } else {
    excluded = excluded_new - excluded_old
  }
  cat(excluded, "excluded\n")
  excluded_old <<- excluded_new
  excluded
}

### counting excluded days

n_excluded_days = function(x) {
  excluded_new_days = sum(is.na(x) | x == FALSE,na.rm = T)
  if (is.null(excluded_old_days)) {
    excluded = excluded_new_days
  } else {
    excluded = excluded_new_days - excluded_old_days
  }
  cat(excluded, "excluded\n")
  excluded_old_days <<- excluded_new_days
  excluded
}

### counting excluded days in social diary

n_excluded_social = function(x) {
  excluded_new_social = sum(is.na(x) | x == FALSE,na.rm = T)
  if (is.null(excluded_old_social)) {
    excluded = excluded_new_social
  } else {
    excluded = excluded_new_social - excluded_old_social
  }
  cat(excluded, "excluded\n")
  excluded_old_social <<- excluded_new_social
  excluded
}

### counting excluded participants in social network

n_excluded_network = function(x) {
  excluded_new_network = sum(is.na(x) | x == FALSE,na.rm = T)
  if (is.null(excluded_old_network)) {
    excluded = excluded_new_network
  } else {
    excluded = excluded_new_network - excluded_old_network
  }
  cat(excluded, "excluded\n")
  excluded_old_network <<- excluded_new_network
  excluded
}

###### strict exclusion
n_excluded_network_strict = function(x) {
  excluded_new_network_strict = sum(is.na(x) | x == FALSE,na.rm = T)
  if (is.null(excluded_old_network_strict)) {
    excluded = excluded_new_network_strict
  } else {
    excluded = excluded_new_network_strict - excluded_old_network_strict
  }
  cat(excluded, "excluded\n")
  excluded_old_network_strict <<- excluded_new_network_strict
  excluded
}

###### bar plot

bar_count = function(data, variable, na.rm = FALSE) {
  varname = deparse(substitute(variable))
  var = data %>% select_(varname) %>% .[[1]]
  if (na.rm == T) {
    var = var %>% na.omit()
  }
  var = factor(var, exclude = NULL)
  data$var = var

  ggplot(data, aes(x = var)) +
    geom_bar() +
    stat_count(aes(label = paste(..count.., "\n", scales::percent(round(..count../sum(count),2)))), hjust = -0.1, geom = "text", position = "identity", na.rm = T) +
    scale_y_continuous(expand = c(0.1, 0)) +
    xlab(varname) +
    coord_flip()
}



multi_rel = function(diary, lme = T, lmer = T) {
  mrel = diary %>%
    group_by(short) %>%
    filter(!is.na(risk_taking)) %>%
    filter(day_number <= 70) %>%
    gather(variable, value, -short, -day_number) %>%
    psych::multilevel.reliability(., "short", "day_number", lme = lme, lmer = lmer, items = "variable", values = "value", long = T, aov = F)
  mrel
}


robust_rowmeans <- function(x) {
  y <- rowMeans(x, na.rm = TRUE)
  y[is.nan(y)] <- NA_real_
  y
}


cortest_stretch <- function(d) {
  var_pairs <- t(combn(names(d), 2)) %>%
    as_data_frame() %>%
    setNames(c("x", "y"))

  p_values <- var_pairs %>%
    dplyr::mutate(r.test = purrr::map2(x, y, ~ stats::cor.test(d[[.x]], d[[.y]])),
                  r.test = purrr::map(r.test, broom::tidy)) %>%
    tidyr::unnest(r.test)
  p_values
}


cut_common_stem <- function(x) {
  i = 1
  while (i <= max(stringr::str_length(x)) & dplyr::n_distinct(stringr::str_sub(x, 1, i)) == 1) {
    i = i + 1
  }
  stringr::str_sub(x, i)
}