R/attach.R

In msberends/certedata: Tools for Data Analysis at Certe

# ==================================================================== #
# TITLE                                                                #
# Tools for Data Analysis at Certe                                     #
#                                                                      #
# AUTHORS                                                              #
# Berends MS (m.berends@certe.nl)                                      #
# Meijer BC (b.meijer@certe.nl)                                        #
# Hassing EEA (e.hassing@certe.nl)                                     #
#                                                                      #
# COPYRIGHT                                                            #
# (c) 2019 Certe Medische diagnostiek & advies - https://www.certe.nl  #
#                                                                      #
# LICENCE                                                              #
# This R package is free software; you can redistribute it and/or      #
# modify it under the terms of the GNU General Public License          #
# version 2.0, as published by the Free Software Foundation.           #
# This R package is distributed in the hope that it will be useful,    #
# but WITHOUT ANY WARRANTY; without even the implied warranty of       #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the         #
# GNU General Public License for more details.                         #
# ==================================================================== #

core_unloaded <- function() {
  search <- paste0("package:", core)
  core[!search %in% search()]
}

# Attach the package from the same package library it was
# loaded from before. https://github.com/tidyverse/tidyverse/issues/171
same_library <- function(pkg) {
  loc <- if (pkg %in% loadedNamespaces()) dirname(getNamespaceInfo(pkg, "path"))
  do.call(
    "library",
    list(pkg, lib.loc = loc, character.only = TRUE, warn.conflicts = FALSE, quietly = TRUE)
  )
}

certedata_attach <- function() {
  to_load <- core_unloaded()
  if (length(to_load) == 0)
    return(invisible())

  msg(
    cli::rule(
      left = crayon::bold("Attaching packages"),
      right = paste0("certedata ", package_version("certedata"), " - \u00A9 Certe")
    ),
    startup = TRUE
  )
  
  versions <- vapply(to_load, package_version, character(1))
  packages <- paste0(
    crayon::green(cli::symbol$tick), " ", crayon::blue(format(to_load)), " ",
    crayon::col_align(versions, max(crayon::col_nchar(versions)))
  )
  
  if (length(packages) %% 2 == 1) {
    packages <- append(packages, "")
  }
  col1 <- seq_len(length(packages) / 2)
  info <- paste0(packages[col1], "     ", packages[-col1])
  
  msg(paste(info, collapse = "\n"), startup = TRUE)
  
  suppressPackageStartupMessages(
    lapply(to_load, same_library)
  )
  
  invisible()
}

package_version <- function(x) {
  version <- as.character(unclass(utils::packageVersion(x))[[1]])
  
  if (length(version) > 3) {
    version[4:length(version)] <- crayon::red(as.character(version[4:length(version)]))
  }
  paste0(version, collapse = ".")
}

#' certedata package conflicts
#' @export
certedata_conflicts <- function() {
  envs <- grep("^package:", search(), value = TRUE)
  envs <- purrr::set_names(envs)
  objs <- invert(lapply(envs, ls_env))
  
  conflicts <- purrr::keep(objs, ~ length(.x) > 1)
  
  tidy_names <- paste0("package:", certedata_packages())
  conflicts <- purrr::keep(conflicts, ~ any(.x %in% tidy_names))
  
  conflict_funs <- purrr::imap(conflicts, confirm_conflict)
  conflict_funs <- purrr::compact(conflict_funs)
  
  structure(conflict_funs, class = "certedata_conflicts")
}

certedata_conflict_message <- function(x) {
  if (length(x) == 0) return("")
  
  header <- cli::rule(
    left = crayon::bold("Conflicts"),
    right = "certedata_conflicts()"
  )
  
  pkgs <- x %>% purrr::map(~ gsub("^package:", "", .))
  others <- pkgs %>% purrr::map(`[`, -1)
  other_calls <- purrr::map2_chr(
    others, names(others),
    ~ paste0(crayon::blue(.x), "::", .y, "()", collapse = ", ")
  )
  
  winner <- pkgs %>% purrr::map_chr(1)
  funs <- format(paste0(crayon::blue(winner), "::", crayon::green(paste0(names(x), "()"))))
  bullets <- paste0(
    crayon::blue(cli::symbol$bullet), " ", funs,
    " masks ", other_calls,
    collapse = "\n"
  )
  
  paste0(header, "\n", bullets)
}

#' @export
print.certedata_conflicts <- function(x, ..., startup = FALSE) {
  cli::cat_line(certedata_conflict_message(x))
}

#' @importFrom dplyr %>%
confirm_conflict <- function(packages, name) {
  # Only look at functions
  objs <- packages %>%
    purrr::map(~ get(name, pos = .)) %>%
    purrr::keep(is.function)
  
  if (length(objs) <= 1)
    return()
  
  # Remove identical functions
  objs <- objs[!duplicated(objs)]
  packages <- packages[!duplicated(packages)]
  if (length(objs) == 1)
    return()
  
  packages
}

ls_env <- function(env) {
  x <- ls(pos = env)
  if (identical(env, "package:dplyr")) {
    x <- setdiff(x, c("intersect", "setdiff", "setequal", "union"))
  }
  x
}

msg <- function(..., startup = FALSE) {
  if (startup) {
    if (!isTRUE(getOption("tidyverse.quiet"))) {
      packageStartupMessage(text_col(...))
    }
  } else {
    message(text_col(...))
  }
}

text_col <- function(x) {
  # If RStudio not available, messages already printed in black
  if (!rstudioapi::isAvailable()) {
    return(x)
  }
  
  if (!rstudioapi::hasFun("getThemeInfo")) {
    return(x)
  }
  
  theme <- rstudioapi::getThemeInfo()
  
  if (isTRUE(theme$dark)) crayon::white(x) else crayon::black(x)
  
}

certedata_packages <- function(include_self = TRUE) {
  # raw <- utils::packageDescription("tidyverse")$Imports
  # imports <- strsplit(raw, ",")[[1]]
  # parsed <- gsub("^\\s+|\\s+$", "", imports)
  # names <- vapply(strsplit(parsed, "\\s+"), "[[", 1, FUN.VALUE = character(1))
  # 
  # if (include_self) {
  #   names <- c(names, "tidyverse")
  # }
  # 
  # names
  if (include_self) {
    core
  } else {
    core[core != "certedata"] 
  }
}

invert <- function(x) {
  if (length(x) == 0) return()
  stacked <- utils::stack(x)
  tapply(as.character(stacked$ind), stacked$values, list)
}

style_grey <- function(level, ...) {
  crayon::style(
    paste0(...),
    crayon::make_style(grDevices::grey(level), grey = TRUE)
  )
}