R/internal_functions.R

In gadget-framework/gadgetutils: Tools to create and maintain gadget3 models

## -----------------------------------------------------------------------------
##
## Miscellaneous functions used in gadgetutils
##
## -----------------------------------------------------------------------------

echo_message <- function(...){
  system(sprintf("echo '%s'", paste0(..., collapse = '')))
}

save_obj <- function(..., file) {
  x <- list(...)
  save(list = names(x), file = file, envir = list2env(x))
}

## A number of g3_* functions in gadgetutils return a list of optimised parameter
## data.frames. Sometimes NULL will be returned from mclapply if a process 
## does not complete. In these cases it would be useful to issue a warning and substitute
## in the input parameters to continue the optimisation

## This is solely used in g3_iterative atm and there is no real reason to use it 
## outside of that function
check_null_params <- function(params_out, params_in){
  
  ## Get index of NULL elements
  params_null <- sapply(params_out, FUN = is.null)
  if (all(params_null)) stop("None of the optimised parameters were returned")
  
  ## Loop over list elements to see if NULL was returned
  for (i in seq_along(params_out)){
    
    if (!is.null(params_out[[i]])){
      
      ## Update the summary attribute if it exists
      if ('summary' %in% names(attributes(params_out[[i]]))){
        attr(params_out[[i]], 'summary')$return_complete <- 1
      }
      
    }
    else{
      
      ## NULL was returned
      warning(paste("A NULL was returned for component", names(params_out[i])))
    
      ## First sort out summary attribute
      sumat <- attributes(params_out[[i]])
      if (is.null(sumat)){
        sumat <- attr(params_out[[which(!params_null)[1]]], 'summary')
        sumat[,c('optim_complete', 'fn_calls', 'gd_calls', 'convergence', 'score')] <- NA
      }
      sumat$return_complete <- 0
      
      ## Second change parameters
      params_out[[i]] <- params_in[[i]]
      params_out[[i]]$value[params_out[[i]]$optimise == 1] <- NA
      
      ## Update attribute
      attr(params_out[[i]], 'summary') <- sumat
      
    }
    
  }
  return(params_out)
}