R/development/review/spawnr/spawn_active.R

In bfatemi/ninjar: Data Science Utility Belt

spawn_active <- function(preview = TRUE){

  loadpkgs <- devtools::loaded_packages()$package
  lib_text <- as.character(sapply(loadpkgs, function(i) paste0("library(", i, ")")))

  dir_proj    <- rstudioapi::getActiveProject()
  doc_context <- rstudioapi::getSourceEditorContext()

  if(is.null(dir_proj))
    stop("spawn_active requires an active project...", call. = FALSE)

  ## create file and remove on exit
  path_fork <- tempfile(fileext = ".R")
  stopifnot(file.create(path_fork))


  ## Write file and fork new R console that will run script
  doc_lines <- doc_context$contents
  doc_string <- paste0(doc_lines, collapse = "\n")

  pat <- "(?<=start_fork\\(\\))[\\s\\S]+?(?=\\nstop_fork\\(\\))"
  fork_text <- str_sub(doc_string, str_locate_all(doc_string, pat)[[1]])
  fork_libs <- paste0(lib_text, collapse = "\n")

  # require start_fork() to be present
  if(length(fork_text) == 0)
    stop("use start_fork() & stop_fork() before/after lines to execute on forked R session", call. = FALSE)

  writeLines(str_c(fork_libs, fork_text), path_fork)

  # if preview is true and rstudio is available, navigate to file
  if(preview & rstudioapi::isAvailable()){
    rstudioapi::navigateToFile(path_fork)
    return(invisible(TRUE))
  }

  ## Run the forked script and source the remainder of this script
  spawn_r(path_tmp)

  pat_beg <- "^[\\s\\S]+?(?=start_fork\\(\\))"
  pat_end <- "(?<=stop_fork\\(\\))[\\s\\S]+?(?=end_run\\(\\))"

  before_text <- str_sub(doc_string, str_locate(doc_string, pat_beg))
  after_text <- str_sub(doc_string, str_locate(doc_string, pat_end))

  parent_lib <- paste0(lib_text, collapse = "\n")
  parent_text <- str_c(parent_lib, "\n", before_text, after_text)

  path_parent <- tempfile(fileext = ".R")
  stopifnot(file.create(path_parent))

  writeLines(parent_text, path_parent)
  source(path_parent, print.eval = TRUE)
}




# stop_fork <- function(){
#   if(!rstudioapi::isAvailable())
#     stop("Ending forked code execution", call. = FALSE)
# }



start_fork  <- function() message("starting fork")
stop_fork   <- function() message("stopping fork")
end_run     <- function() message("Ignoring below")

# dconsole_edit <- rstudioapi::getConsoleEditorContext()
# src_edit <- rstudioapi::getSourceEditorContext()
#
# rstudioapi::setSelectionRanges()
# rstudioapi::primary_selection(x = )



###
### DECLARE FORK FUNCTIONS THAT HELP WITH SEARCH PATH SETUP
###

# function to get user loaded packages
sp_loaded <- function(){
  spDF <- packrat::search_path()
  usr_pkgs <- spDF$package[spDF$lib.dir == Sys.getenv("R_LIBS_USER")]
  return(usr_pkgs)
}

# function to initialize new fork by making the directory
fork_init <- function(){
  fk_name <- paste0("fk_session_", sample(1:10000, 1))
  fk_dir <- paste0(tempdir(), "\\", fk_name)
  stopifnot(dir.create(fk_dir, recursive = TRUE))

  message("save global variable to track sessions")
  normalizePath(fk_dir, "/")
}

# saves a character list of packages to the forked directory
fork_packages <- function(pkgs, fkdir){
  saveRDS(pkgs, paste0(fkdir, "/load_pkgs"))
  TRUE
}

# given the forked directory path, this function saves an environment to be used on new fork
fork_env <- function(share_env, fkPath){
  pkgs <- sp_loaded()

  with(share_env, {
    ns_txt <- paste0("package:", pkgs)

    bool <- try({
      sapply(ns_txt, function(i){
        pos <- which(search() == i)
        detach(pos = pos)
        TRUE
      })
    }, silent = TRUE)

    if(sum(bool) < length(pkgs))
      stop("unable to detach package: ", pkgs[!bool])

    tryCatch({
      saveRDS(serialize(share_env, NULL), paste0(fkPath, "/share_env"))
    }, error = function(c){
      stop(c)
    }, warning = function(c){
      TRUE
    })
  })
}



###
### CREATE FUNCTION THAT WILL SETUP THE SESSION ON THE NEW FORK
###

##  --- DO NOT DELETE BELOW ---

##
# setwd("C:/Users/Bobbyf/Documents/GitHub/")
#
# dir_path <- "ninjar/fork_session_6112/"
# setwd(dir_path)
# getwd()
#
# ## Load packages ##
# session_name <- "fork_session_6112"
# load_pkgs <- readRDS("load_pkgs")
#
# sapply(load_pkgs, function(pkg){
#   try(attachNamespace(asNamespace(pkg)), silent = TRUE)
#   TRUE
# })
# rlang::scoped_names()
#
# ## Load environment ##
# share_env <- unserialize(readRDS("share_env"))
# env_bind(.GlobalEnv, as.list(share_env))
##

##  --- DO NOT DELETE ABOVE ---



###
### RUN EXAMPLE CODE
###

fkPath <- fork_init()
pkgs <- sp_loaded()
fork_packages(pkgs, fkPath)


env       <- env_clone(globalenv())
env$DAT   <- as.data.table(iris)
env$var_x <- "TEST"
env$var_y <- "ANOTHER TEST"

fork_env(env, fkPath)






# env <- rlang::env_set_parent(, list(shareDT = DT))
# eval(address(DT), globalenv())
# eval(address(shareDT), env)




# env$shareDT <- DT
#
# address(DT)
# eval(address(shareDT), env)
# ?rlang::env_bind
#
#
# HPDS_ENV <- function() rlang::env_clone(globalenv())
# HPDS_ENV <-
# `%[->%` <- function(x, env){
#   list(
#     object = x,
#     location = pryr::address(x),
#     mem_size = pryr::object_size(x)
#   )
# }

# CHECK <- function(x){
#   if(exists(x, rlang::caller_env()))
#     return(x)
#   stop("Object does not exist", call. = FALSE)
# }

# o1 <- iris
# o2 <- setDT(o1)
# o3 <- o1
# o4 <- globalenv()$o1
#
# o5 <- data.table(o1)
# o6 <- globalenv()$o5
#
# o7 <- as.data.table(o6)
#
# o8 <- copy(o4)
#
#
# address(o1)
# address(o2)
# address(o3)
# address(o4)
# address(o5)
# address(o6)
# address(o7)
# address(o8)
#
# x %ENV% globenv
#
# x <- end_run
# do.call(quote, list(x))
#
# shared_env <- globalenv()
#
# sum(sapply(ls(shared_env), function(i) object_size(i, shared_env)))/0.001
#
# object_size(spawn_active)
# address()
# rlang::env_get(shared_env, "after_text")
#
#
# eval(pryr::address(after_text), shared_env)
#
#
#
#
#
# rstudioapi::get
#
# ##
# ##
#
# `@!--- START_FORK ---->` <- R6::R6Class("hpds",
#                                         active = list(
#                                          load_lib = function(libs){
#                                            if(missing(libs)){
#
#                                            }
#                                          }
#                                         ))
# $`library`
#
#
# `~> START -+-+-+-+->>`@`_HPDS_`@`----`
# ##
# ## The lines of code between the
# ##
# `%!!% -------`@STOP_FORK@`-------% !! %`















#
#
# with_env(nenv, search())
#
# ##
# ## save all attached namespaces
# ##
#
# rlang::scoped_names()
# saveRDS(asNamespace("rlang"), "namespaces/ns_base")
#
#
# # Get clone of global environment to pass to new session, and create a fresh env to test
# share_env <- rlang::env_clone(globalenv())
# fresh_env <- new.env(parent = baseenv())
#
#
#
# # get all user loaded
#
# parent.env(base_env())
#
#
#
# rlang::scoped_names()
#
# rlang::base_env()
# with(rlangenv, namespaceImport())
#
# #
# #
# # all_scoped <-
# # fresh_scoped <-
#
# pkg_scoped <- str_replace(all_scoped[str_detect(all_scoped, "package:")], "package:", "")
#
# asNamespace("package:easydata")
#
# share_env$is_visible <- TRUE
# saveRDS(share_env, "share_env")
#
# rlang::with_env(
#   env = fresh_env,
#
#   expr = {
#
#     library(easydata)
#     rlang::scoped_names()
#
#   })
#
#
# env      <- rlang::caller_env()   # global env
# fork_env <- rlang::env_clone(env) # parent is global env
#
# fork_env$ONLYINFORK <- TRUE
#
#
# rlang::env_set
# parent.env()
# rlang::env_set_parent(.GlobalEnv, fork_env)
#
#
# ?.GlobalEnv
#
#
# attach(fork_env)
#
# environment(.Last)
# readRDS()
# saveRDS(fork_env, "fork_env")
#
#
# env$foo      <- 42 # defined in global
# fork_env$bar <- 13 # defined in clone of global
#
# f <- function() foo+bar
# b <- serialize(f, NULL) # Gives you the serialized bytes
# g <- unserialize(b) # Loads from the bytes
#
#
#
# eval(g(), envir = fork_env)
#
# # It created new environments...
# !identical(environment(g), environment(f))
#
#
#
# saveRDS(fork_env, "fork_env")
#
# readRDS("fork_env")
#
# delayedAssign(x, value, eval.env = parent.frame(1),
#               assign.env = parent.frame(1))