R/general_utilities.R

In allosaurus-scientificus/fouu: functions of uncertain utility

#' Current month plus or minus months.
#'
#' description goes here
#'
#' details go here
#' @param x integer of months to add or substract from current
#' @importFrom magrittr %>% 
#' @export 
cur_mon <- function(x = 0L) lubridate::floor_date(Sys.Date(), "month") + months(x)


#' rename columns with underscores
#'
#' description goes here
#'
#' details go here
#' @param df a data.frame imported from somewhere with cols names I don't like
#' @importFrom magrittr %>% 
#' @export 
rename_cols <- function(df){
  
  colnames(df) <- df %>% 
    colnames() %>% 
    tolower() %>% 
    make.names() %>% 
    purrr::map_chr(~gsub("[.]", "_", .x))

  return(df)  
  
}



#' Calculate percent difference.
#'
#' description goes here
#'
#' details go here
#' @param o observed quantity
#' @param e expected quantity
#' @export
perc_diff <- function(o = 1, e = 1) {
  
  stopifnot(e != 0 & is.numeric(o) & is.numeric(e))
  
  round((o - e) / e , 4) 
}


#' Signed log hack.
#'
#' description goes here
#'
#' details go here
#' @param x a number
#' @export
signed_log <- function(x = -100L) {
  
  stopifnot(is.numeric(x))
  
  sign(x) * log10(sqrt(x^2))
  
}

#' Determine if integer64.
#'
#' found that postgres counts return as integer64 and that sometimes == no bueno
#' combining with \code{ddplyr::mutate_if} handy
#'
#' details go here
#' @param x whatever you think might be integer64
#' @export
is.integer64 <- function(x) "integer64" %in% class(x)



#' Flatten lists, because sometime you do.
#'
#' at the end of mapping sometimes have 2-level list, which I do not want (often)
#'
#' details go here
#' @param alist a list
#' @importFrom magrittr %>% 
#' @export
#' @examples 
#' \dontrun{
#' list_fu <- list(phuey = dplyr::tibble(v1 = sample(letters[1:4], 4, replace = TRUE) %>% c(),
#'                                v2 = sample(0L:9L, 4, replace = TRUE) %>% c()),
#'                 fooie = dplyr::tibble(v1 = sample(letters[23:26], 4, replace = TRUE) %>% c(),
#'                                v2 = sample(0L:9L, 4, replace = TRUE) %>% c()))
#' flatten_list(alist = list_fu)
#' }
flatten_list <- function(alist){
  
  stopifnot(class(alist) == "list")
  
  alist %>% 
    names() %>% 
    purrr::map_df(.f = ~list_fu[[.x]] %>% dplyr::mutate(list_name = .x))
  
}


#' Make sf url.
#' 
#' description here
#' 
#' details here
#' 
#' @param d domain of sf instance
#' @param x unique record suffix
#' @param y name to appear in link
#' @export
sf_url <- function(d, x, y){
  
  paste0("=HYPERLINK(\"https://", d, ".my.salesforce.com/", x, "\", \"", y, "\")")
  
}


#' Standardized \code{ggsave}.
#' 
#' description here
#' 
#' details here
#' @param p \code{ggplot} plot
#' @param name name of \code{.png} exported to Downloads
export_png <- function(p, name){
  
  ggplot2::ggave(filename = paste0("~/Downloads/", as.character(name)),
                 plot = p,
                 width = 7,
                 height = 4,
                 dpi = 300,
                 units = "in",
                 device = "png")
}


#' Unpacking forecasts.
#' 
#' forecasts from \code{forecast} come as lists, so need to unpack for \code{dygraphs}.
#' 
#' details here
#' 
#' @param fc is a forecast object from \code{forecast}
#' @param cl confidence level if > 1 in output
#' @export
fc_to_dygraph <- function(fc, cl = 1){
  
  y <- fc$x
  lower <- fc$lower[ , cl]
  upper <- fc$upper[, cl]
  yhat <- fc$mean
  
  cbind(y, lower, upper, yhat)
}


#' Select columns based on percent NA.
#' 
#' columns with all or some \code{NA} values may not useful
#' 
#' details here
#' 
#' @param df is a data frame
#' @param na_limit what percent \code{NA} should be dropped
#' @export
#' @importFrom magrittr %>% 
#' @examples 
#' \dontrun{
#' df_na <- tibble(
#'   none_na = sample(letters, 100, replace = TRUE),
#'   some_na = sample(c(0L:2L, NA), 100, replace = TRUE),
#'   half_na = sample(c(TRUE, NA, FALSE, NA), 100, replace = TRUE),
#'   most_na = sample(c(TRUE, FALSE, NA, NA, NA, NA), 100, TRUE),
#'   all_na = rep(NA, 100))
#' drop_na_col(df_na)
#' drop_na_col(df_na, na_limit = .25)
#' }
drop_na_col <- function(df, na_limit = 1){
  
  stopifnot(is.numeric(na_limit) & na_limit >= 0 & na_limit <= 1)
  
  index <- df %>% 
    purrr::map(.f = ~ sum(is.na(.x)) / length(.x)) %>% 
    purrr::map_lgl(.f = ~ .x ==  0 | .x < na_limit)
  
  df[, index, drop = FALSE]
  
}