ncbi: Retrieve data from NCBI.

setOldClass('list')

#' Collection-class
#' 
#' A container of S4 objects with a shared environment that may contain metadata.
#' 
#' @seealso
#' \code{\link{makeCollectionClass}}, \code{\link{collectionConstructor}},
#' \code{\link{collectionValidator}}, \code{\link{collectionShower}}.rt
#' @name Collection-class
#' @rdname Collection-class
#' @keywords internal classes
new_Collection <- setClass(
  Class='Collection',
  contains = 'list',
  slots = c(elementType = 'character', shared = 'environment'),
  prototype = prototype(elementType = NA_character_,
                        shared = new.env(parent=emptyenv()))
)


#' Create a Collection Class Definition 
#' 
#' Create a subclass to \code{\linkS4class{Collection}} named
#' \code{<elementClass>List} and return a constructor function.
#' 
#' The constructor function is generated by a call to
#' \code{\link{collectionConstructor}}, a simple validity-checking
#' method is supplied by a call to \code{\link{collectionConstructor}}.
#' 
#' If a \code{show} method has been defined for the Collection elements,
#' a generic \code{show} method can be constructed by a call to
#' \code{\link{collectionShower}}.
#' 
#' @param elementClass Class name of the elements.
#' @return A constructor function for \code{<elementClass>List}-Class.
#' @seealso
#' \code{\linkS4class{Collection}}, \code{\link{collectionConstructor}},
#' \code{\link{collectionValidator}}, \code{\link{collectionShower}}.
#' @keywords internal
makeCollectionClass <- function(elementClass) {
  assert_that(isClass(elementClass))
  listClass <- paste0(elementClass, 'List')
  validator <- collectionValidator(eval(listClass))
  setClass(listClass,
           contains="Collection",
           prototype = prototype(elementType = elementClass),
           validity = validator,
           where = topenv(parent.frame()))
  collectionConstructor(eval(listClass))
}


#' @keywords internal
#' @docType methods
setGeneric("elementType", function(x, ...) standardGeneric("elementType"))
setMethod("elementType", "Collection", function(x) x@elementType)


setAs("Collection", "list", function(from) from@.Data)
## in order for lapply et al. to work with Collections it seems that
## "as.list" must be defined as an S4 method
#' @export
#' @docType methods
setMethod("as.list", "Collection", function(x, ...) {
  as(x, "list")
})


#' @keywords internal
#' @docType methods
setGeneric('shared', function(x, i, ...) standardGeneric('shared'))

## `shared` without arguments returns the shared environment itself
setMethod("shared", c(x="Collection", i="missing"), function(x) x@shared)

## extract objects from the shared environment. The extracted object is
## NOT copied.
setMethod("shared", c(x="Collection", i="ANY"), function(x, i) {
  tryCatch(get(i, x@shared, inherits=FALSE), error = function(e) NULL)
})


#' @keywords internal
#' @docType methods
setGeneric('shared<-', function(x, i, value, ...) standardGeneric('shared<-'))


setReplaceMethod("shared", c(x="Collection", i="ANY", value="ANY"),
                 function(x, i, value, ...) {
                   assert_that(length(i) == 1L)
                   assign(i, value, x@shared)
                   x
                 })


## Remove an object from a shared environment by setting it NULL
setReplaceMethod("shared", c(x="Collection", i="ANY", value="NULL"),
                 function(x, i, value, ...) {
                   assert_that(length(i) == 1L, nzchar(i))
                   rm(list=as.character(i), pos=x@shared)
                   x
                 })


#' @export
setMethod("[", "Collection", function(x, i, j, ..., drop) {
  new(class(x), callNextMethod(), elementType = elementType(x),
      shared = shared(x))
})


#' @export
setMethod("[[", "Collection", function(x, i, j, ...) {
  callNextMethod()
})


#' Create a constructor function for a Collection class.
#'  
#' @param Class Name of the collection class.
#' @keywords internal
collectionConstructor <- function(Class) {
  assert_that(is.string(Class))
  assert_that(extends(Class, "Collection"))
  
  function(..., shared = new.env(parent=emptyenv())) {
    listData <- list(...)
    elementType <- elementType(new(Class))
    if (length(listData) == 0L) {
      new(Class, list(new(elementType)), elementType=elementType, shared=shared)
    } else {
      if (length(listData) == 1L && is.list(listData[[1L]])) 
        listData <- listData[[1L]]
      if (!all(vapply(listData, is, elementType, FUN.VALUE=logical(1L)))) 
        stop("All elements in '...' must be '", elementType,"' objects")
      
      new(Class, .Data=listData, elementType=elementType, shared=shared)
    }
  }
}


#' Create a validity-checking method for a Collection class.
#'  
#' @param Class Name of the collection class.
#' @keywords internal
collectionValidator <- function(Class) {
  assert_that(is.string(Class))
  function(object) {
    errors <- character()
    elementType <- elementType(object)
    elem_of_class <- vapply(as(object, "list"), is, elementType, FUN.VALUE=logical(1L))
    if (!all(elem_of_class)) {
      msg <- paste0("All elements in a '", Class ,"' must be of type '", elementType, "'.")
      errors <- c(errors, msg)
    }
    if (length(errors) == 0L) TRUE else errors
  }
}


#' Create a show-method for a Collection class.
#'  
#' @param showFun show function for Collection class elements.
#' @param numOfElements Number of elements to show as head and tail.
#' @param linesPerElement How many lines per element before the show-string
#' is elipsized.
#' @importFrom assertthat has_args
#' @keywords internal
collectionShower <- function(showFun, numOfElements = 6, linesPerElement = NULL) {
  assert_that(is.function(showFun), has_args(showFun, c('x', 'width', 'ellipsis')))
  assert_that(is.numeric(numOfElements), length(numOfElements) == 1)
  
  showElements <- function(index, elems, lPerEl = NULL, ellipsis = ' ... ' ) {
    index_string <- paste0('[[', index, ']] ')
    if (is.null(lPerEl)) {
      width <- Inf
    } else {
      indent <- nchar(index_string) + nchar(ellipsis) + 2L*lPerEl + 1L
      width <- lPerEl*getOption("width") - indent
    }
    object_string <- unlist(Map(showFun, x=elems, width=width, ellipsis=ellipsis))
    sprintf("%s%s", index_string, linebreak(object_string, indent = -nchar(index_string),
                                            offset=1L, FORCE=TRUE))
  }
  
  ##' @param x A Collection instance
  ##' @param nOfEl how many Collection elements do we show as head and tail.
  ##' @param lPerEl how many lines per collection element to we want to show
  ##' before we ellipsize.
  function(x,
           nOfEl = getOption('numOfElements') %||% numOfElements,
           lPerEl = getOption('linesPerElement') %||% linesPerElement) {
    data <- as.list(x)
    ll <- length(data)
    cat(sprintf("A %s instance of length %s\n", sQuote(class(x)), ll), sep="")
    
    if (ll == 0L) {
      showme <- ''
    } else if (ll > 2*nOfEl) {
      head_index <- seq_len(nOfEl)
      head <- data[head_index]
      showHead <- showElements(head_index, head, lPerEl)
      tail_index <- seq.int(to=ll, length.out = min(nOfEl, ll))
      tail <- data[tail_index]
      showTail <- showElements(tail_index, tail, lPerEl)
      showme <- c(showHead, '...', showTail)
    } else {
      showme <- showElements(seq_along(data), data, lPerEl)
    }
    cat(showme, sep="\n")
  }
}