R/apollo_compareInputs.R

In apollo: Tools for Choice Model Estimation and Application

#' Compares the content of apollo_inputs to their counterparts in the global environment
#' 
#' @param apollo_inputs List grouping most common inputs. Created by function \link{apollo_validateInputs}.
#' @return Logical. TRUE if the content of \code{apollo_inputs} is the same than the one in the global environment, FALSE otherwise.
#' @export
apollo_compareInputs <- function(apollo_inputs){
  # Validate input
  if(!is.list(apollo_inputs)) stop('INTERNAL ISSUE - Argument "apollo_inputs" should be a list generated by "apollo_validateInputs"')
  gEnv <- globalenv()
  ans <- TRUE
  txt <- c()
  
  # Compare database
  db <- tryCatch(get('database', envir=gEnv, inherits=FALSE), error=function(e) NULL)
  if(!is.null(db) && !is.null(apollo_inputs$database)){
    same <- is.data.frame(db) && is.data.frame(apollo_inputs$database)
    tmp  <- which(names(apollo_inputs$database)=='apollo_sequence') # do not consider apollo_sequence or ID (latter only if HB)
    if(apollo_inputs$apollo_control$HB & all(names(db)!='ID') ) tmp <- c(tmp, which(names(apollo_inputs$database)=='ID'))
    if(length(tmp)>0) tmp <- -tmp else tmp <- 1:ncol(apollo_inputs$database)
    tmp2 <- which(names(db)=='apollo_sequence') # do not consider apollo_sequence
    if(length(tmp2)>0) tmp2 <- -tmp2 else tmp2 <- 1:ncol(db)
    same <- same && all(dim(db[,tmp2])==dim(apollo_inputs$database[,tmp]))
    same <- same && all(mapply(identical, db[,tmp2], apollo_inputs$database[,tmp]))
    if(!same){ ans <- FALSE; txt <- c(txt, 'database') }
  }
  
  # Compare apollo_draws
  x <- tryCatch(get('apollo_draws', envir=gEnv, inherits=FALSE), error=function(e) NULL)
  if(!is.null(x) && !is.null(apollo_inputs$apollo_draws)){
    na   <- length(x)==1 && length(apollo_inputs$apollo_draws)==1
    na   <- na && is.na(x) && is.na(apollo_inputs$apollo_draws)
    same <- is.list(x) && is.list(apollo_inputs$apollo_draws)
    same <- same && !is.null(names(x)) && !is.null(names(apollo_inputs$apollo_draws))
    same <- same && all(names(x) %in% names(apollo_inputs$apollo_draws))
    if(same) for(e in names(x)){
      same <- same && identical(x[[e]], apollo_inputs$apollo_draws[[e]])
    }
    if(!na && !same){ ans <- FALSE; txt <- c(txt, 'apollo_draws') }
  }
  
  # Compare apollo_control. Only checks elements that exist in globalenv()$apollo_control.
  x <- tryCatch(get('apollo_control', envir=gEnv, inherits=FALSE), error=function(e) NULL)
  x$outputDirectory <- apollo_inputs$apollo_control$outputDirectory
  if(!is.null(x) && !is.null(apollo_inputs$apollo_control)){
    same <- is.list(x) && is.list(apollo_inputs$apollo_control)
    same <- same && !is.null(names(x)) && !is.null(apollo_inputs$apollo_control)
    tmp  <- names(x)
    if(any(tmp=='analyticGrad_manualSet')) tmp <- tmp[tmp!='analyticGrad_manualSet']
    if(same) for(e in tmp){
      same <- same && !is.null(apollo_inputs$apollo_control[[e]])
      same <- same && identical(x[[e]], apollo_inputs$apollo_control[[e]])
    }
    if(!same){ ans <- FALSE; txt <- c(txt, 'apollo_control') }
  }
  
  # Compare apollo_HB. Only checks elements that exist in globalenv()$apollo_HB.
  x <- tryCatch(get('apollo_HB', envir=gEnv, inherits=FALSE), error=function(e) NULL)
  if(!is.null(x) && !is.null(apollo_inputs$apollo_HB)){
    na   <- length(x)==1 && length(apollo_inputs$apollo_HB)==1
    na   <- na && is.na(x) && is.na(apollo_inputs$apollo_HB)
    same <- is.list(x) && is.list(apollo_inputs$apollo_HB)
    same <- same && !is.null(names(x)) && !is.null(apollo_inputs$apollo_HB)
    if(same) for(e in names(x)[!(names(x)%in%c("fixedA","fixedD","constraintsNorm"))]){
      same <- same && !is.null(apollo_inputs$apollo_HB[[e]])
      same <- same && identical(x[[e]], apollo_inputs$apollo_HB[[e]])
    }
    if(!na && !same){ ans <- FALSE; txt <- c(txt, 'apollo_HB') }
  }
  
  # Compare apollo_randCoeff
  x <- tryCatch(get('apollo_randCoeff', envir=gEnv, inherits=FALSE), error=function(e) NULL)
  if(!is.null(x) && !is.null(apollo_inputs$apollo_randCoeff)){
    #na   <- length(x)==1 && length(apollo_inputs$apollo_randCoeff)==1
    #na   <- na && is.na(x) && is.na(apollo_inputs$apollo_randCoeff)
    same <- is.function(x) && is.function(apollo_inputs$apollo_randCoeff)
    same <- same && identical(x, apollo_inputs$apollo_randCoeff)
    if(!same){ ans <- FALSE; txt <- c(txt, 'apollo_randCoeff') }
  }
  
  # Compare apollo_lcPars
  x <- tryCatch(get('apollo_lcPars', envir=gEnv, inherits=FALSE), error=function(e) NULL)
  if(!is.null(x) && !is.null(apollo_inputs$apollo_lcPars)){
    #na   <- length(x)==1 && length(apollo_inputs$apollo_lcPars)==1
    #na   <- na && is.na(x) && is.na(apollo_inputs$apollo_lcPars)
    same <- is.function(x) && is.function(apollo_inputs$apollo_lcPars)
    same <- same && identical(x, apollo_inputs$apollo_lcPars)
    if(!same){ ans <- FALSE; txt <- c(txt, 'apollo_lcPars') }
  }
  
  # print message
  if(is.null(apollo_inputs$silent) || !is.logical(apollo_inputs$silent)) silent <- FALSE else silent <- apollo_inputs$silent
  if(!ans && !silent){
    one <- length(txt)==1
    txt <- paste0('Element', ifelse(one,' ', 's '), paste0(txt, collapse=', '), 
                  ' in the global environment differ', ifelse(one,'s ', ' '), 'from ',
                  ifelse(one, 'that ', 'those '), ' inside apollo_inputs. The latter will be used. ',
                  'If you wish to use the former, stop this function by pressing the "Escape" key, ', 
                  'and rerun apollo_validateInputs before calling this function.')
    apollo_print(txt, pause=5, type="w")
  }
  
  return(invisible(ans))
}