Global Environment helpers for rstudio

rst_environments.R

# Environment Utilities ----------------------------------------------
#' Clean all lines out of the console.
#'
#' \code{env.clear_console}
#'
#'
#' Rstudio Server can get really slow if a lot of text, especially unicode
#'  or foreign data types are sitting in the GUI. This function is the equiv
#'  of \code{Edit > Ctrl + L}
#'
#' @family Environment utilities
#'
#'
#' @export
env.clear_console <- function(){
  cat("\014")
}

#' Function to index every object in an environment or namespace
#'
#' \code{env.idx}
#'
#'
#' This function is helpful when space becomes cluttered, or even for finding
#' and calling alternate variables or functions from within a space
#'
#'
#' @param filter_class string or character vector, Pass the class of objects
#'  to be returned, if NULL, the default, return all.
#'
#' @param env string This variable interprets the input as a package name, or
#'  the default, global, the working invironment. This is the environment from
#'  which we want the objects from.
#'
#' @param pattern A regular expression or string to find in the environment.
#'
#'  @return
#' \format{
#'  A data frame with 77 observations on the following 2 variables.
#'  \describe{
#'    \item{\strong{obj_name}}{\emph{a character vector}
#'         This is the name of the object within the
#'         active, or called namespace.}
#'    \item{\strong{obj_type}}{\emph{a character vector}
#'         The class of the object. Such as character,
#'         data.frame, environment etc.}
#'   }
#' }
#'
#' @author Carl S.A. Boneri, \email{carl@@gmail.com}
#'
#'
#' @examples
#' ============  ========
#' obj_name      obj_type
#' ============  ========
#' .             function
#' aaply         function
#' adply         function
#' alply         function
#' amv_dimnames  function
#' a_ply         function
#' ============  ========
#'
#' @export
env.idx <- function(filter_class = NULL, env = 'global', pattern = NULL){

  if(env != 'global'){
    if(!grepl('^package', env)){
      get_from <- sprintf('package:%s', env)
    }else {
      get_from <- env
    }
  }else {
    get_from <- .GlobalEnv
  }

  var_jects <- ls(pos = get_from, all.names = TRUE)

  IDX <-
    ldply(var_jects, function(i){
      IST <-
        ifelse(env != 'global',
               class(get(i, pos = get_from)),
               class(get(i))
        )
      i_size <- object.size(deparse(substitute(i)))

      c(obj_name = i,
        obj_type = IST)
    })

  IDX$`obj_size(kb)` <- unlist(llply(1:nrow(IDX), function(i){
    object.size(get(IDX$obj_name[[i]])) * 0.001
  }))

  IDX$`obj_size(mb)` <- unlist(llply(1:nrow(IDX), function(i){
    object.size(get(IDX$obj_name[[i]])) * 1e-6
  }))


  if(!is.null(filter_class)){
    IDX <- IDX %>% filter(grepl(filter_class,obj_type)) %>%
      arrange(`obj_size(kb)`)
  }else {
    IDX <- IDX  %>%
      arrange(`obj_size(kb)`)
  }

  if(!is.null(pattern)){
    IDX <- IDX[grepl(pattern, IDX$obj_name),]
  }
  return(IDX)
}

#' Function for clearing all objects from cache in a session
#'
#'
#' \code{env.clear_objects}
#'
#'
#' Working in an environment or in an app can mean the workspace or
#' in-memory storage can get bogged down with unecessary data objects. This
#' can impact speed or simply clutter the space itself. This function will
#' remove all objects that are not functions in the current environment.
#'
#'
#' @family Environment utilities
#'
#'
#' @export
env.clear_objects <- function(keep_pat = NULL){
  the_objz <- sapply(ls(envir = .GlobalEnv), function(i){
    is.function(get(i, envir = .GlobalEnv))
  }) %>% .[!.] %>% names
  if(!is.null(keep_pat)){
    the_objz <- the_objz[stri_detect_regex(
      the_objz, pattern = keep_pat,
      negate = TRUE
    )]
  }
  
  rm(list = the_objz, envir = .GlobalEnv)
}



#' Clear all created functions from an environment
#'
#' \code{env.clean_funs}
#'
env.clear_funs <- function(keep_pat = NULL){
  the_funz <- ldply(mapply(function(x){
    mode(get(x))
  }, ls(env = .GlobalEnv))
  ) %>% select(.id, mode_of = 2) %>% 
    dplyr::filter(
      mode_of == "function"
    ) %>% .$.id
  
  if(!is.null(keep_pat)){
    the_funz <- the_funz[stri_detect_regex(
      the_funz, pattern = keep_pat,
      negate = TRUE
    )]
  }
  rm(list = the_funz, envir = .GlobalEnv)
}

#' Create a new Global Environment
#'
#'
#' \code{env.new}
#'
#'
#' Works much like calling \code{\link{new.env()}} but allows passing a string
#' argument to assign to the environment namespace. Useful within function calls
#' where a new env can be used to mask operations and send outputs early to
#' outside functions while the intended function completes its steps.
#'
#'
#' @param env_name String, the name of the new environment.
#'
#'
#' @examples
#'
#' env.new('.hidden')
#'
env.new <- function(env_name = NULL){
  check_name <- tryCatch(is.character(env_name), error = function(e)FALSE)

  if(check_name){
    assign(env_name, new.env(), envir = .GlobalEnv)
  }else {
    set_name <- deparse(substitute(env_name))
    assign(set_name, new.env(), envir = .GlobalEnv)
  }
}



#' A wrapper to make everything silent
#'
#' \code{shh}
#'
#'
shh <- function(...){
  invisible(
    suppressWarnings(
      suppressPackageStartupMessages(
        suppressMessages(
          ...
        )
      )
    )
  )
}



# env.ensure <- function(x = NULL, create_if_not = TRUE, silent = FALSE){
#
#   chk <- tryCatch(x, error = function(e){
#     # Possibly the cheapest, ugliest work-around I've ever pulled...
#     (gsub("^(.*?)object '|' not found>$","",capture.output(e)))
#   })
#
#   if(!is.environment(chk)){
#     if(!create_if_not){
#       return(chk)
#     }else {
#       assign(chk, new.env(), envir = .GlobalEnv) %>% (function(x){
#         if(typeof(x) == "environment"){
#           point <- as.environment(x)
#           if(!silent){
#             return(point)
#           }
#         }
#       })
#     }
#   }else {
#     point <- as.environment(chk)
#     if(!silent){
#       return(point)
#     }
#   }
#
# }

#' Return an object as an environment
#'
#' \code{env.ensure}
#'
#' Primarily for both ensuring an environment exists, as well as allowing
#' for flexibility in the input format between a quoted, or non-quoted
#' object.
#'
#' If the object-variable does not exists, the name passed into the function
#' will be assigned into the \code{.GlobalEnv} as a new object.
#'
#' If the object-variable already exists, nothing is created.
#'
#'
#' @param e_in The name of the environment to check for or create
#'
#'
#' @return
#' The calling identity of the parent frame: ie the calling parents
#' unique id.
#'
#'
#' @examples
#' > env.ensure(e_in = this_new_e)
#'  <environment: 0x0000000019de5fc0>
#'
#' > this_new_e
#' <environment: 0x0000000019de5fc0>
#'
#' > env.ensure(e_in = "this_new_e1")
#' <environment: 0x0000000019f5f018>
#'
#'
env.ensure <- function(e_in = NULL){

  e_in <- names(as.quoted(substitute(e_in)))
  if(!is.null(e_in)){
    if(!exists(e_in)){
      var_e <- new.env()
      assign(e_in, var_e, envir = .GlobalEnv)
    }else if(is.environment(e_in)){
      var_e <- as.environment(e_in)
    }else {
      var_e <- as.environment(get(e_in, envir = .GlobalEnv))
    }
  }else {
    var_e <- environment()
  }
  return(var_e)
}



#' Assign a data object into an environment
#
#e_assign <- function(.x = NULL, .name = NULL, .e_out = globalenv(), ...){
#  lapply(as.list(match.call(expand.dots = TRUE))[-1], is.call)
#}
# > e_assign(.x = iris, .name = iris_data, .e_out = 'carl1', my = function(u)u + 1)
# $.x
# [1] FALSE
#
# $.name
# [1] FALSE
#
# $.e_out
# [1] FALSE
#
# $my
# [1] TRUE
#
#



#' Check if a library is loaded in the environment
#'
#' \code{env.lib_lookup}
#'
env.lib_lookup <- function(lib = NULL){
  get_loaded <- gsub("package:", "", grep(
    sprintf("package:(?!%s|base)",
            paste0(sessionInfo()[[5]], collapse = "|")),
    search(), value = TRUE, perl = TRUE))
  if(!lib %in% get_loaded){
    if(!lib %in% row.names(installed.packages())){
      cat(sprintf('The %s package is not installed locally', lib))
    }else {
      library(lib, character.only = TRUE)
    }
  }else {
    return(TRUE)
  }
}




# Library and Package utils ------------------------------------------
#' Helper function to ensure no outputs from loading or detaching libraries
#'
#' \code{libs.shh}
#'
#' @param x The list of libraries to be loaded
#'
#' @param lib_action Either adding libraries or removing.
#'
#' @family Loading functions
#' @seealso \code{\link{libs.detach}},
#' @seealso \code{\link{libs.live}},
#' @seealso \code{\link{libs.load}},
#' @seealso \code{\link{libs.shh}}
#'
#' @export
libs.shh <- function(x, lib_action = c('add','detach')){
  if(length(lib_action) == 2){
    lib_action_f <- "library"
  }else {
    lib_action_f <- switch(lib_action,
                           'add' = "library",
                           'detach' = "detach")
  }

  invisible(
    suppressPackageStartupMessages(
      suppressMessages(
        lapply(x, function(i){
          do.call(lib_action_f,list(i, character.only = T))
        })
      )
    ))

}

#' Get all of the libraries loaded into a namespace that are not part of base
#'
#' \code{libs.live}
#'
#'
#' @family Loading functions
#'
#' @seealso \code{\link{libs.detach}},
#' @seealso \code{\link{libs.live}},
#' @seealso \code{\link{libs.load}},
#' @seealso \code{\link{libs.shh}}
#'
#'
#' @export
libs.live <- function(){
  sprintf("package:%s",names(sessionInfo()[[6]]))
}


#' Helper function for loading multiple libraries from a loop
#'
#'
#' \code{libs.load}
#'
#'
#' Useful function for loading libraries in a clean loop silently and from
#' a reference list. Helpful in \code{shiny} as included in the global.R or
#' the server.R scripts, as a clean way to save space and ensure package deps
#' are loaded properly.
#'
#' @param add_lib string Add a library to the default list which is set by the
#'  function itself.
#'
#' @return NULL
#'
#' @family Loading functions
#'
#'
#' @seealso \code{\link{libs.detach}},
#' @seealso \code{\link{libs.live}},
#' @seealso \code{\link{libs.load}},
#' @seealso \code{\link{libs.shh}}
#' @author Carl S.A. Boneri, \email{carl.boneri@@whyles.com}
#'
#' @examples
#'
#' # Currently loaded libraries
#' > cat(paste0(c("#'",libs.live()), collapse =  "  \code{'\n'}#' # "))
#'
#' # package:roxygen2
#' # package:jsonlite
#' # package:rCharts
#' # package:sodium
#' # package:dplyr
#' # package:plyr
#' # package:reshape2
#' # package:stringi
#' # package:RCurl
#' # package:bitops
#' # package:curl
#' # package:rvest
#' # package:httr
#' # package:htmlwidgets
#' # package:htmltools
#' # package:leaflet
#' # package:shiny
#'
#'
#' # Now detach only curl
#'
#' libs.detach("curl")
#' > ls(pos = "package:curl")
#' Error in as.environment(pos) :
#'    no item called "package:curl" on the search list
#'
#' # Deatch every package that is loaded into the environment
#' libs.detach()
#'
#' # verify that all are detached
#' > libs.live()
#'   character(0)
#'
#' # Load all of the defaults back in
#' > libs.load()
#'
#' > cat(paste0(c("#'",libs.live()), collapse =  "  \code{'\n'}#' # "))
#'
#' # package:jsonlite
#' # package:rCharts
#' # package:sodium
#' # package:dplyr
#' # package:plyr
#' # package:reshape2
#' # package:stringi
#' # package:RCurl
#' # package:bitops
#' # package:curl
#' # package:rvest
#' # package:httr
#' # package:htmlwidgets
#' # package:htmltools
#' # package:leaflet
#' # package:shiny
#'
#' # Add devtools, knitr and roxygen2 to the default list
#' > libs.load(add_lib = c("devtools", "knitr","roxygen2"))
#'
#' > cat(paste0(c("#'",libs.live()), collapse =  "  \code{'\n'}#' # "))
#'
#' # package:roxygen2
#' # package:knitr
#' # package:devtools
#' # package:jsonlite
#' # package:rCharts
#' # package:sodium
#' # package:dplyr
#' # package:plyr
#' # package:reshape2
#' # package:stringi
#' # package:RCurl
#' # package:bitops
#' # package:curl
#' # package:rvest
#' # package:httr
#' # package:htmlwidgets
#' # package:htmltools
#' # package:leaflet
#' # package:shiny
#'
#'
#' @export
libs.load <- function(add_lib = NULL){

  default_libs <- list(
    'parallel',
    'devtools',
    'tools',
    'knitr',
    'roxygen2',
    'readr',
    'readxl',
    'shiny',
    'leaflet',
    'htmltools',
    'htmlwidgets',
    'httr',
    'curl',
    'rvest',
    'xml2',
    'XML',
    'RCurl',
    'stringi',
    'stringdist',
    'dplyr',
    'plyr',
    'reshape2',
    'sodium',
    'rCharts',
    'jsonlite',
    'microbenchmark',
    'rbenchmark',
    'profvis',
    'data.table'
  )
  if(!is.null(add_lib)){
    default_libs <- append(default_libs, add_lib)
  }

  libs.shh(default_libs, lib_action = "add")

}

#' Detach all packages and libraries from a workspace or environment
#'
#'
#' \code{libs.detach}
#'
#' @param lib_name Names of libraries to detach if we're not detaching all
#'
#' @family Loading functions
#'
#' @seealso \code{\link{libs.detach}},
#' @seealso \code{\link{libs.live}},
#' @seealso \code{\link{libs.load}},
#' @seealso \code{\link{libs.shh}}
#'
#' @export
libs.detach <- function(lib_name = NULL){
  if(!is.null(lib_name)){
    bye_libs <- sprintf("package:%s", lib_name)
  }else {
    bye_libs <- libs.live()
  }
  libs.shh(bye_libs, lib_action = "detach")
}