inst/tools/funcs.R

load_scripts <- function(..., asis = FALSE){
  src = c(...)
  
  for(s in src){
    cat2('Loading source - ', s, '\n', level = 'INFO', sep = '')
    source(get_path(s), local = F)
  }
}

define_initialization <- function(expr){
  expr = substitute(expr)
  eval(expr, envir = parent.frame())
}


define_input <- function(definition, init_args, init_expr){
  definition = substitute(definition)
  init_expr = substitute(init_expr)
  
  parser = rave:::comp_parser()
  
  comp = parser$parse_quo(rlang::quo(!!definition))
  
  def_text = deparse(comp$expr)
  def_text = paste(def_text, collapse = '\n  ')
  input_id = comp$inputId
  
  f = eval(definition[[1]])
  env_name = environmentName(environment(f))
  if(env_name == ''){env_name = '<No Name>'}
  
  cat2('Input Definition - ', level = 'INFO')
  cat2(' ', def_text, level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
  
  cat2('Package/Environment - \t', level = 'INFO', end = '')
  cat2(env_name, level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
  
  val = comp$initial_value
  
  
  
  
  # Update info
  if(!missing(init_args)){
    cat2('Updating Input Parameter(s) - ', level = 'INFO')
    
    env = new.env(parent = parent.frame())
    eval(init_expr, envir = env)
    for(arg in init_args){
      v = env[[arg]]
      v = paste(deparse(v), collapse = '\n  ')
      
      cat2(' ', arg, '- ', level = 'INFO', pal = list('INFO' = 'orangered'), end = '')
      cat2(v, level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
    }
    
    if('value' %in% init_args){
      val = env[['value']]
    }else if('selected' %in% init_args){
      val = env[['selected']]
    }
    
  }
  
  v = paste(deparse(val), collapse = '\n  ')
  
  cat2('Input Value - \t', level = 'INFO', end = '')
  cat2(input_id, '= ', level = 'INFO', pal = list('INFO' = 'orangered'), end = '')
  cat2(v, level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
  
  assign(input_id, val, envir = parent.frame())
  invisible(val)
}



define_output <- function(definition, title, width, order){
  
  assertthat::assert_that(width %in% 1:12, msg = 'Width must be from 1 to 12')
  
  parser = rave:::comp_parser()
  definition = substitute(definition)
  
  comp = parser$parse_quo(rlang::quo(!!definition))
  
  f = eval(definition[[1]])
  env_name = environmentName(environment(f))
  if(env_name == ''){env_name = '<No Name>'}
  
  cat2('Title - \t\t', level = 'INFO', end = '')
  cat2(title, level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
  
  cat2('Definition - \t\t', level = 'INFO', end = '')
  cat2(paste(deparse(comp$expr), collapse = '\n  '), level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
  
  cat2('Package/Environment - \t', level = 'INFO', end = '')
  cat2(env_name, level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
  
  cat2('Width - \t\t', level = 'INFO', end = '')
  cat2(sprintf('%d (%.1f%% of output panel width)', width, width/12*100), level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
  
  cat2('Order - \t\t', level = 'INFO', end = '')
  cat2(order, level = 'INFO', pal = list('INFO' = 'dodgerblue3'))
  
  # try to locate function
  
  output_id = comp$outputId
  
  pname = get_package_name()
  penv  = loadNamespace(pname)
  f = get0(output_id, envir = penv, ifnotfound = NULL, inherits = FALSE)
  
  
  if(is.function(f)){
    if(length(formals(f))){
      cat2('Output function `', output_id, '` found in package ', pname, '.', level = 'INFO', sep = '')
    }else{
      cat2('Output function `', output_id, '` MUST take in at least one argument(s)!', level = 'ERROR', sep = '')
    }
  }else{
    fn_found = FALSE
    if(stringr::str_detect(deparse(definition[[1]]), '(customizedUI)|(uiOutput)|(htmlOutput)')){
      f = get0(output_id, envir = globalenv(), ifnotfound = NULL, inherits = FALSE)
      if(is.function(f) && length(formals(f))){
        cat2('Output function `', output_id, '` found in global environment. (Shiny-RAVE Customized UI)', level = 'INFO', sep = '')
        fn_found = TRUE
      }
    }
    if(!fn_found){
      cat2('Cannot find output function `', output_id, '` in package ', pname, '!', level = 'ERROR', sep = '')
    }
  }
  
}


rave_checks <- function(...){
  
  if(is_local_debug()){
    args = list(...)
    tryCatch({
      do.call(rave::rave_checks, args)
    }, error = function(e){
      cat2('The following data will be checked: ', unlist(args), sep = '\n\t', level = 'INFO')
    })
  }else{
    rave::rave_checks(...)
  }
}



`$<-.dev_ReactiveInput` = `[[<-.dev_ReactiveInput` = function(x, i, value){
  if(x$..warn){
    assign('..warn', FALSE, envir = x)
    cat2('$<-, or [[<- type of assignment only works for debug purpose.\n  (This warning only display once for this object)', level = 'WARNING')
  }
  
  assign(i, value, envir = x)
  invisible(x)
}

print.dev_ReactiveInput <- function(x){
  cat2('<Reactive Input> (Read-only)', level = 'INFO')
  for(k in ls(x, all.names = FALSE)){
    cat2(' ', k, '= ', level = 'INFO', pal = list('INFO' = 'orangered'), end = '')
    s = paste(deparse(x[[k]]), sep = '\n\t')
    cat2(s, level = 'INFO', pal = list('INFO' = 'dodgerblue3'), sep = '\n\t')
  }
  invisible(x)
}

getDefaultReactiveInput <- function(){
  if(is_local_debug()){
    env = new.env(parent = emptyenv())
    env$..warn = TRUE
    class(env) = c('dev_ReactiveInput', 'environment')
    env
  }else{
    f = get('getDefaultReactiveInput', parent.env(parent.env(..param_env)))
    f()
  }
  
}


getDefaultReactiveDomain <- function(){
  if(is_local_debug()){
    rave:::fake_session()
  }else{
    f = get('getDefaultReactiveDomain', parent.env(parent.env(..param_env)))
    f()
  }
}


`$<-.dev_ReactiveOutput` = `[[<-.dev_ReactiveOutput` = function(x, i, value){
  value = substitute(value)
  assign(i, value, envir = x)
  invisible(x)
}

print.dev_ReactiveOutput <- function(x){
  cat2('<Reactive Output> (Write-only)', level = 'INFO')
  for(k in ls(x, all.names = FALSE)){
    cat2(' ', k, '= ', level = 'INFO', pal = list('INFO' = 'orangered'), end = '')
    s = paste(deparse(x[[k]]), sep = '\n\t')
    cat2(s, level = 'INFO', pal = list('INFO' = 'dodgerblue3'), sep = '\n\t')
  }
  invisible(x)
}

getDefaultReactiveOutput <- function(){
  if(is_local_debug()){
    env = new.env(parent = emptyenv())
    env$..warn = TRUE
    class(env) = c('dev_ReactiveOutput', 'environment')
    env
  }else{
    f = get('getDefaultReactiveOutput', parent.env(parent.env(..param_env)))
    f()
  }
}

print.dev_ReactiveValues <- function(x){
  cat2('<Reactive Values> (Write-only)', level = 'INFO')
  for(k in ls(x, all.names = FALSE)){
    cat2(' ', k, '= ', level = 'INFO', pal = list('INFO' = 'orangered'), end = '')
    s = paste(deparse(x[[k]]), sep = '\n\t')
    cat2(s, level = 'INFO', pal = list('INFO' = 'dodgerblue3'), sep = '\n\t')
  }
  invisible(x)
}


reactiveValues <- function(...){
  if(is_local_debug()){
    env = new.env(parent = emptyenv())
    list2env(list(...), env)
    
    class(env) = c('dev_ReactiveValues', 'environment')
    env
  }else{
    shiny::reactiveValues(...)
  }
}
beauchamplab/firstPkg documentation built on June 1, 2019, 3:55 a.m.