psyntur source code

psyntur_0_0_2.R

library(tidyverse)
library(rlang)

ansur <- read_csv("http://data.ntupsychology.net/ansur.csv")

describe <- function(data, by = NULL, ...){
  if (is.null(enexpr(by))){
    summarise(data, ...)
  } else {
    summarise(group_by(data, across({{ by }})), ..., .groups = 'drop')
  }
  
}


describe_across <- function(data, variables, functions, by = NULL, pivot = FALSE){
  
  if (!is.null(enexpr(by))){
    data <- group_by(data, across({{ by }}))
  }
  
  if (!pivot){
    results <- data %>% 
      summarise(across({{ variables }}, functions), .groups = 'drop')
  } else {
    results <- data %>% 
      summarise(across({{ variables }}, functions, .names = "{.fn}_____{.col}"), .groups = 'drop') %>%
      tidyr::pivot_longer(cols = contains('_____'),
                          names_to = c('.value', 'variable'),
                          names_sep = '_____')
  }
  
  results
}



sum_xna <- function(...) base::sum(..., na.rm = TRUE)

mean_xna <- function(...) base::mean(..., na.rm = TRUE)


median_xna <- function(...) stats::median(..., na.rm = TRUE)


iqr_xna <- function(...) stats::IQR(..., na.rm = TRUE)


sd_xna <- function(...) stats::sd(..., na.rm = TRUE)


var_xna <- function(...) stats::var(..., na.rm = TRUE)





scatterplot <- function(x, y, data, by = NULL, best_fit_line = FALSE){
  
  if (is.null(enexpr(by))) {
    the_aes <- aes(x = {{ x }}, y = {{ y }})
  } else {
    the_aes <- aes(x = {{ x }}, y = {{ y }}, colour = {{ by }})
  }
  p1 <- ggplot(data = data, mapping = the_aes ) + geom_point()
  
  if (best_fit_line){
    p1 <- p1 + stat_smooth(method = 'lm', se = FALSE, fullrange = TRUE, formula = 'y ~ x')
  }
  
  p1 + theme_classic() + scale_colour_brewer(palette = "Set1")#ggthemes::scale_colour_colorblind()
}


tukeyboxplot <- function(y, x, data, 
                         by = NULL,
                         jitter = FALSE, 
                         box_width = 1/3,
                         jitter_width = 1/5){
  
  # If `x` is missing, and so we have one boxplot, use an empty `x` variable
  # with x = ''.
  if (missing(x)){
    the_aes <- aes(x = '', y = {{ y }})
  } else {
    the_aes <- aes(x = {{ x }}, y = {{ y }})
  }
  
  # If we have a `by`, set that as the "colour" aesthetic
  if (!is.null(enexpr(by))) {
    the_aes$colour <- enexpr(by)
  }
  
  # If we have a continuous `x` variable, we need to use aes(group = ...)
  if (!missing(x)){
    
    # If we have a `by` variable, we need to group by an interaction
    if (!is.null(enexpr(by))) {
      the_aes$group <- quo(interaction(!!enexpr(x), !!enexpr(by)))
    } else {
      the_aes$group <- enexpr(x)
    }
  }
  
  # The basic plot
  p1 <- ggplot(data, mapping = the_aes)
  
  # With jitter, 
  # the jitter
  # Set jitter to a fraction of box_width.
  if (jitter) {
    
    # outliers should be removed as they will be shown in the jitter
    p1 <- p1 + geom_boxplot(width = box_width, outlier.shape = NA)
    
    if (!is.null(enexpr(by))) {
      p1 <- p1 + geom_jitter(position = position_jitterdodge(dodge.width = box_width, jitter.width = box_width * jitter_width/2), size = 0.85, alpha = 0.75)
    } else {
      p1 <- p1 + geom_jitter(width = box_width * jitter_width/2, size = 0.85, alpha = 0.75)
    }
    
  } else {
    p1 <- p1 + geom_boxplot(width = box_width, outlier.size = 0.75)
  }
  
  # If `x` is missing, we don't want any ticks or labels on 'x' axis.
  if (missing(x)) p1 <- p1 + xlab(NULL) + theme(axis.ticks = element_blank()) 
  
  p1 + theme_classic() + scale_colour_brewer(palette = "Set1")
}


histogram <- function(x, data, by = NULL, position = 'stack', facet = NULL, facet_type = 'wrap', bins = 10, alpha = 1.0){
  
  if (is.null(enexpr(by))) {
    the_aes <- aes(x = {{ x }})
  } else {
    the_aes <- aes(x = {{ x }}, fill = {{ by }})
  }
  
  p1 <- ggplot(data, mapping = the_aes) + geom_histogram(bins = bins,
                                                         colour = 'white',
                                                         position = position,
                                                         alpha = alpha)
  
  if (!is.null(enexpr(facet))) {
    
    # this monstrosity to deal with unquoted, possibly vector, arguments
    # to facet
    facet_expr <- enexpr(facet)
    
    if(length(facet_expr) == 1) {
      facet_vars <- as.list(facet_expr)
    } else {
      facet_vars <- as.list(facet_expr)[-1]
    }
    
    quoted_facet_vars <- sapply(facet_vars, rlang::quo_name)
    
    if (facet_type == 'wrap'){
      p1 <- p1 + facet_wrap(quoted_facet_vars, labeller = label_both)
    } else if (facet_type == 'grid'){
      p1 <- p1 + facet_grid(quoted_facet_vars, labeller = label_both)
    } else {
      stop(sprintf('facet_type should be "wrap" or "grid" not %s', facet_type))
    }
  }
  
  # minimal looks better than classic in a faceted plot
  if (is.null(enexpr(facet))) {
    p1 + theme_classic() + scale_fill_brewer(palette = "Set1")
  } else {
    p1 + theme_minimal() + scale_fill_brewer(palette = "Set1")
  }
  
}