#  File R/control.utilities.R in package statnet.common, part of the Statnet suite
#  of packages for network analysis, https://statnet.org .
#
#  This software is distributed under the GPL-3 license.  It is free,
#  open source, and has the attribution requirements (GPL Section 7) at
#  https://statnet.org/attribution
#
#  Copyright 2007-2020 Statnet Commons
#######################################################################
.autodetect_dep_warn <- local({
  warned <- c()
  function(caller = as.character(ult(sys.calls(),3)[[1L]])){
    if(!caller %in% warned)
      warning("In ",sQuote(caller),": Autodetection of acceptable control parameter generators and of the calling function name has been deprecated and will be removed in a future version. They must be set explicitly.", call.=FALSE)
    warned <<- c(warned, caller)
  }
})

#' Check if the class of the control list is one of those that can be used by
#' the calling function
#' 
#' This function can be called to check that the control list passed is
#' appropriate for the function to be controlled. It does so by looking up the
#' class of the \code{control} argument (defaulting to the \code{control}
#' variable in the calling function) and checking if it matches a list of
#' acceptable classes.
#' 
#' @param OKnames List of control function names which are acceptable.
#' @param myname Name of the calling function (used in the error message).
#' @param control The control list. Defaults to the \code{control} variable in
#' the calling function.
#' @note In earlier versions, `OKnames` and `myname` were autodetected. This capability has been deprecated and results in a warning issued once per session. They now need to be set explicitly.
#' @seealso [set.control.class()], [print.control.list()]
#' @keywords utilities
#' @export
check.control.class <- function(OKnames=as.character(ult(sys.calls(),2)[[1L]]), myname=as.character(ult(sys.calls(),2)[[1L]]), control=get("control",pos=parent.frame())){
  if(missing(OKnames) || missing(myname)) .autodetect_dep_warn() 
  funs <- paste("control", OKnames, sep=".")
  
  if(inherits(control, funs[1L])) return(TRUE)
  
  for(fun in funs[-1]) # If there is only one, that's a null vector, so it just terminates.
    if(inherits(control, fun)){
      warning("Using ", fun,"(...) as the control parameter of ",myname,"(...) is suboptimal and may overwrite some settings that should be preserved. Use ",funs[1L],"(...) instead.")
      return(FALSE)
    }
  
  stop("Invalid control parameters for ",myname,"(...): ",class(control)[1L],"(...). Use ",funs[1L],"(...) to construct them instead.", call.=FALSE)
}



#' Set the class of the control list
#' 
#' This function sets the class of the control list, with the default being the
#' name of the calling function.
#' 
#' 
#' @param myname Name of the class to set.
#' @param control Control list. Defaults to the \code{control} variable in the
#' calling function.
#' @return The control list with class set.
#' @note In earlier versions, `OKnames` and `myname` were autodetected. This capability has been deprecated and results in a warning issued once per session. They now need to be set explicitly.
#' @seealso [check.control.class()], [print.control.list()]
#' @keywords utilities
#' @export
set.control.class <- function(myname=as.character(ult(sys.calls(),2)[[1L]]), control=get("control",pos=parent.frame())){
  if(missing(myname)) .autodetect_dep_warn()
  class(control) <- c(myname, "control.list", "list")
  control
}



#' Pretty print the control list
#' 
#' This function prints the control list, including what it can control and the
#' elements.
#' 
#' 
#' @param x A list generated by a \code{control.*} function.
#' @param \dots Additional argument to print methods for individual settings.
#' @param indent an argument for recursive calls, to facilitate indentation of nested lists.
#' @seealso \code{\link{check.control.class}}, \code{\link{set.control.class}}
#' @keywords utilities
#' @export
print.control.list <- function(x, ..., indent=""){
  cat("Control parameter list generated by", sQuote(class(x)[1L]), "or equivalent. Non-empty parameters:\n")
  for(name in names(x)){
    if(length(x[[name]])){
      cat(indent, name,": ",sep="")
      if(is.list(x[[name]])) {print(x[[name]], ..., indent=paste0(indent,"   "))} else cat(paste(deparse(x[[name]]), collapse=" "),"\n", sep="")
    }
  }
}

#' Named element accessor for ergm control lists
#' 
#' Utility method that overrides the standard `$' list accessor to disable
#' partial matching for ergm \code{control.list} objects
#' 
#' Executes \code{\link[base]{getElement}} instead of \code{\link[base]{$}} so
#' that element names must match exactly to be returned and partially matching
#' names will not return the wrong object.
#' 
#' @param object list-coearceable object with elements to be searched
#' @param name literal character name of list element to search for and return
#' @return Returns the named list element exactly matching \code{name}, or
#' \code{NULL} if no matching elements found
#' @author Pavel N. Krivitsky
#' @seealso see \code{\link{getElement}}
#' @name control.list.accessor
#' @export
`$.control.list` <- function(object, name) object[[name, exact = TRUE]]



#' Overwrite control parameters of one configuration with another.
#' 
#' Given a \code{control.list}, and two prefixes, \code{from} and \code{to},
#' overwrite the elements starting with \code{to} with the corresponding
#' elements starting with \code{from}.
#' 
#' 
#' @param control An object of class \code{control.list}.
#' @param from Prefix of the source of control parameters.
#' @param to Prefix of the destination of control parameters.
#' @return An \code{control.list} object.
#' @author Pavel N. Krivitsky
#' @seealso \code{\link{print.control.list}}
#' @keywords utilities
#' @examples
#' 
#' (l <- set.control.class("test", list(a.x=1, a.y=2)))
#' control.remap(l, "a", "b")
#' 
#' @export
control.remap <- function(control, from, to){
  from <- paste0("^",from,"\\.")
  to <- paste0(to,"\\.")
  nfrom <- grep(from, names(control), value=TRUE)
  nto <- sub(from, to, nfrom)
  for(i in seq_along(nfrom)) control[[nto[i]]] <- control[[nfrom[i]]]
  control
}


#' Identify and the differences between two control lists.
#' @param x a `control.list`
#' @param y a reference `control.list`; defaults to the default
#'   settings for `x`.
#' @param ignore.environment whether environment for
#'   environment-bearing parameters (such as formulas and functions)
#'   should be considered when comparing.
#' @param ... Additional arguments to methods.
#'
#' @return An object of class `diff.control.list`: a named list with
#'   an element for each non-identical setting. The element is either
#'   itself a `diff.control.list` (if the setting is a control list)
#'   or a named list with elements `x` and `y`, containing `x`'s and
#'   `y`'s values of the parameter for that setting.
#' @export
diff.control.list <- function(x, y=eval(call(class(x)[[1L]])), ignore.environment=TRUE, ...){
  d <- list()
  for(name in union(names(x),names(y))){
    d[[name]] <-
      if(is(x[[name]], "control.list") && is(y[[name]], "control.list")) EVL(diff(x[[name]], y[[name]]))
      else if(!identical(x[[name]],y[[name]],ignore.environment=ignore.environment)) list(x=x[[name]], y=y[[name]])
  }
  structure(d, class=c("diff.control.list", "list"), xclass=c(class(x)[1L]))
}

#' @describeIn diff.control.list A print method.
#' @param indent an argument for recursive calls, to facilitate
#'   indentation of nested lists.
#' @export
print.diff.control.list <- function(x, ..., indent = ""){
  if(length(x)==0) cat("No difference between parameter lists generated by", sQuote(attr(x,"xclass")), "or equivalent.\n")
  else{
    cat("Difference between parameter lists generated by", sQuote(attr(x,"xclass")), "or equivalent. Differences:\n")
    for(name in names(x)){
      if(length(x[[name]])){
        cat(indent, name,": ",sep="")
        if(is(x[[name]],"diff.control.list")) print(x[[name]], ..., indent=paste0(indent,"   "))
        else if(is.list(x[[name]]$x)){
          print(x[[name]]$x, ..., indent=paste0(indent,"   "))
          cat("versus")
          print(x[[name]]$y, ..., indent=paste0(indent,"   "))
        }else{
          cat(paste(deparse(x[[name]]$x), collapse=" "), " versus ",
              paste(deparse(x[[name]]$y), collapse=" "), "\n", sep="")
        }
      }
    }
  }
}
