R/control.utilities.R

Defines functions control.remap print.control.list set.control.class check.control.class

Documented in check.control.class control.remap print.control.list set.control.class

#  File R/control.utilities.R in package statnet.common, part of the Statnet suite
#  of packages for network analysis, http://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
#  http://statnet.org/attribution
#
#  Copyright 2007-2017 Statnet Commons
#######################################################################
.autodetect_dep_warn <- local({
  warned <- c()
  function(caller = {sc <- sys.calls(); as.character(sc[[length(sc)-2]][[1]])}){
    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={sc <- sys.calls(); as.character(sc[[length(sc)-1]][[1]])}, myname={sc <- sys.calls(); as.character(sc[[length(sc)-1]][[1]])}, control=get("control",pos=parent.frame())){
  if(missing(OKnames) || missing(myname)) .autodetect_dep_warn() 
  funs <- paste("control", OKnames, sep=".")
  
  if(inherits(control, funs[1])) 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[1],"(...) instead.")
      return(FALSE)
    }
  
  stop("Invalid control parameters for ",myname,"(...): ",class(control)[1],"(...). Use ",funs[1],"(...) 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={sc <- sys.calls(); as.character(sc[[length(sc)-1]][[1]])}, 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 Unused at this time.
#' @seealso \code{\link{check.control.class}}, \code{\link{set.control.class}}
#' @keywords utilities
#' @export
print.control.list <- function(x, ...){
  cat("Control parameter list generated by", class(x)[1], "or equivalent. Non-NULL parameters:\n")
  for(name in names(x)){
    if(!is.null(x[[name]])){
      cat(name,": ",sep="")
      if(is.list(x[[name]])) print(x[[name]]) else cat(x[[name]],"\n")
    }
  }
}

#' 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
}

Try the statnet.common package in your browser

Any scripts or data that you put into this service are public.

statnet.common documentation built on Aug. 16, 2017, 5:04 p.m.