.packageName <- "AffyCompatible"
## Functions used after class definition, to define accessors, by
## default, to all slots not beginning with .*

.nameAll <- function(x) {
    ## Add names to character vector x.  Elements of x without names get
    ## a name matching the element.
    ##
    if (is.null(x)) return(character(0))
    else if (!is.character(x))
      stop("argument 'x' must be a character vector")
    names(x) <- 
      if (length(names(x)) > 0)
        ifelse(nzchar(names(x)), names(x), x)
      else
        x
    x
}

.newSlotNames <- function(class) {
    ## slot name sdefined in this class, not inheritted
    nms <- names(slot(getClass(class), "contains"))
    ext <- unique(unlist(lapply(nms, slotNames)))
    nms <- slotNames(class)
    nms[!nms %in% ext]
}

.accessors <- function(class, slots=.newSlotNames(class),
                       where=topenv(parent.frame()), ...) {
    .getters(class, slots, where, ...)
    .setters(class, slots, where, ...)
}

.getters <- function(class, slots=.newSlotNames(class),
                     where=topenv(parent.frame()), ...) {
    slots <- .nameAll(slots)
    nms <- names(slots)
    for (i in seq_along(slots)) {
        tryCatch({
          eval(substitute({
            if (!isGeneric(GENERIC, where=where) &&
                GENERIC != "length")
                setGeneric(GENERIC,
                           function(x) standardGeneric(GENERIC),
                           useAsDefault=FALSE,
                           where=WHERE)
            if (!existsMethod(GENERIC,
                              signature=signature(x=CLASS),
                              where=where))
              setMethod(GENERIC,
                        signature=signature(x=CLASS),
                        function(x) slot(x, SLOT),
                        where=WHERE)
        }, list(CLASS = class,
                GENERIC = nms[[i]],
                SLOT = slots[[i]],
                WHERE = where)))
        }, error=function(err) {
          warning(sprintf("could not create '%s': %s",
                          nms[[i]], conditionMessage(err)))
        })
    }
}

.setters <- function(class, slots=.newSlotNames(class),
                     where=topenv(parent.frame()), ...) {
    slots <- .nameAll(slots)
    nms <- names(slots)
    for (i in seq(along=slots)) {
        try(eval(substitute({
            if (!isGeneric(SETTER, where=where))
                setGeneric(SETTER, function(x, value)
                           standardGeneric(SETTER),
                           where = WHERE)
            setReplaceMethod(GENERIC,
                             signature=signature(
                               x=CLASS,
                               value=getSlots(CLASS)[[SLOT]]),
                             function(x, value) {
                                 slot(x, SLOT) <- value
                                 validObject(x)
                                 x
                             },
                             where = WHERE)
        }, list(CLASS=class,
                GENERIC=nms[[i]],
                SETTER=paste(nms[[i]], "<-", sep=""),
                SLOT=slots[[i]],
                WHERE=where))))
    }
}

## .validity

.validity <- function(object) TRUE

setGeneric(".validity")

## .TypedAssociation

setClass(".TypedAssociation",
         representation=representation(
           .extends="character"),
         contains="list",
         validity=.validity)

.TypedAssociation <- function(extends) {
  new(".TypedAssociation", .extends=extends)
}
## Base class for all classes in this package
setClass("AffyCompatible")              # VIRTUAL

## DTT / ARR support

setClass("DTTCompatibility", "AffyCompatible")

setClass("ARRCompatibility", "AffyCompatible")

## NetAffxResource

setClass("NetAffxCompatibility", "AffyCompatible")

setClass("NetAffxResource",
         contains="NetAffxCompatibility",
         representation=representation(
           directory="character",
           annotationsFile="character",
           affxUrl="character",
           affxLicence="character",
           user="character",
           password="character"),
         prototype=prototype(
           directory=tempdir(),
           annotationsFile="NetAffxAnnotFileList.xml",
           affxUrl="https://www.affymetrix.com/analysis/downloads/netaffxapi/GetFileList.jsp"),
         validity=.validity)
.xreserved <- function()
  c( ## attributes
    'class', 'comment', 'dim', 'dimnames', 'names',
    'row.names', 'tsp',
    ## incorrect implict generic
    'order', 'row', 'array', 'sequence', 'url', 'file',
    'title', 'text', 'person', 'image', 'start', 'end',
    ## no suitable arguments to dispatch methods
    'date', 'category')

.xnames <- function(names, prefix=character(0)) {
    ## how element names are mapped to slot names -- lowercase, except for reserved
    if (length(prefix)==1) {
        idx <- grep(paste("^",  prefix, sep=""), names, perl=TRUE)
        updt <- setdiff(seq_len(length(names)), idx)
        names[updt] <- sub("^([A-Z]+)", "\\L\\1", names[updt], perl=TRUE)
        repl <- paste(prefix, "\\U\\1", sep="")
        names[updt] <- sub("^([[:alpha:]])", repl, names[updt], perl=TRUE)
    }
    names <- sub("^([A-Z]+)", "\\L\\1", names, perl=TRUE)
    idx <- names %in% .xreserved()
    names[idx] <- sub("^([[:alpha:]])", "affx\\U\\1", names[idx], perl=TRUE)
    names
}

.xclassnames <- function(cls, prefix=character(0)) {
    if (length(prefix)==1) {
        cls <- .xnames(cls, prefix)
        sub("^([[:alpha:]])", "\\U\\1", cls, perl=TRUE)
    } else {
        cls
    }
}

.xmlDoc <- function(xmlNodeOrDoc) {
    if (!"XMLInternalDocument" %in% class(xmlNodeOrDoc))
        xmlNodeOrDoc <- xmlDoc(xmlNodeOrDoc)
    xmlNodeOrDoc
}

.xvalue <- function(xmlNode, xpathq) {
  unlist(xpathApply(.xmlDoc(xmlNode), xpathq, xmlValue))
}

.xpcdata <- function(xmlNode) {
  ## FIXME: comments?
  xpathApply(.xmlDoc(xmlNode), "/*/text()", xmlValue)
}

.xattrs <- function(xmlNode, prefix) {
  attrs <- as.list(xmlAttrs(xmlNode))
  names(attrs) <- .xnames(names(attrs), prefix)
  attrs
}

.xassn <- function(xmlNode, xpath, type_constructor, assn_constructor) {
  types <- xpathApply(.xmlDoc(xmlNode), xpath, type_constructor)
  assn_constructor(types)
}

.xclass <- function(node, ..., prefix) {
  if (!is(node, "XMLInternalNode"))
    stop("'node' must be of class 'XMLInternalNode'")
  nodeNm <- .xclassnames(xmlName(node), prefix)
  pcdata <- list()
  if (".Data" %in% slotNames(getClass(nodeNm)))
    pcdata <- .xpcdata(node)
  attrs <- .xattrs(node, prefix)
  assnNodes <- xpathApply(.xmlDoc(node), "/*/*")
  if (length(assnNodes)>0) {
    nms <- .xclassnames(sapply(assnNodes, xmlName), prefix=prefix)
    elts <- lapply(assnNodes, .xclass, prefix=prefix)
    assnNms <- unique(nms)
    assns <- lapply(assnNms, function(nm, ...) {
      new(".TypedAssociation", elts[nms==nm], .extends=nm)
    })
    names(assns) <- .xnames(assnNms, prefix)
  } else {
    assns <- list()
  }
  do.call("new", c(nodeNm, pcdata, attrs, assns))
}

xclass <- function(doc, xpathq, prefix=character(0)) {
  xpathApply(doc, xpathq, .xclass, prefix=prefix)
}

.readXmlAsClass <- function(fl, ..., prefix=character(0)) {
  xml <- xmlTreeParse(fl, useInternal=TRUE, ...)
  xclass(xml, "/*", ..., prefix=prefix)
}

readXml <- function(fl, ...)
  xmlTreeParse(fl, useInternal=TRUE, ...)
.TypedAssociation_validity <- function(object) {
  msg <- NULL
  extends <- .extends(object)
  if (!all(sapply(object, is, extends)))
    msg <- c(msg,
             sprintf("all elements must extend '%s'", extends))
  if (is.null(msg)) TRUE
  else msg
}

setMethod(".validity",
          signature=c(object=".TypedAssociation"),
          .TypedAssociation_validity)

.getters(".TypedAssociation")

.TypedAssociation <- function(extends, ...) {
  new(".TypedAssociation", .extends=extends, ...)
}

setMethod("[",
          signature=signature(
            x=".TypedAssociation"),
          function(x, i, j, ..., drop=TRUE) {
            stop("'[' with subscript(s) i='",
                 if (missing(i)) "missing" else class(i),
                 "', j='",
                 if (missing(j)) "missing" else class(j),
                 "' not supported")
          })

setMethod("[",
          signature=signature(
            x=".TypedAssociation",
            i="numeric",
            j="missing"),
          function(x, i, j, ..., drop=TRUE) {
            if (length(x)==0)
              stop("cannot subset 0-length '", .extends(x), "'")
            if (any(!i %in% seq(1, length(x))))
              stop("'[' subscript i must be in 1:", length(x))
            slot(x, ".Data") <- .Data(x)[i]
            x
          })

setMethod("show",
          signature=signature(
            object=".TypedAssociation"),
          function(object) {
            cat(.extends(object), "(", length(object), ")\n", sep="")
          })
## class building

.xmlElementDef <- function(elt, contains, prefix=character(0), verbose=FALSE) {

  .xmlElementContent <- function(contents) {
    if(is.null(contents$elements) && names(contents$type)=="PCData")
      ".PCData"
    else contents$elements
  }

  .xmlOrContent <- function(contents) {
    ## rapply classes="character" is a hack; only 'element' items are class character
    as.vector(rapply(contents$elements, force,
                     classes="character", how="unlist"))
  }

  .xmlSequenceContent <- function(contents) {
    ## rapply classes="character" is a hack; only 'element' items are class character
    as.vector(rapply(contents, force,
                     classes="character", how="unlist"))
  }

  .xmlContent <- function(contents, contentFunction) {
    cls <- contentFunction(contents)
    if (".PCData" %in% cls) {
      contains <- c("character", contains)
      cls <- cls[cls!=".PCData"]
    }
    elts <- .xnames(cls, prefix)
    slts[elts] <- ".TypedAssociation"
    do.call("setClass",
            list(elt$name,
                 representation=do.call("representation", slts),
                 contains=contains))
    
  }

  elt$name <- .xclassnames(elt$name, prefix)
  if (!isClass(elt$name)) {
    slts <- as.list(rep("character", length(elt$attributes)))
    names(slts) <- .xnames(lapply(elt$attributes, "[[", "name"),
                           prefix)

    contents <- elt$contents
    if (verbose) cat(elt$name, "\n")
    switch(class(contents),
           "NULL"={
             do.call("setClass",
                     list(elt$name,
                     representation=do.call("representation", slts),
                     contains=contains))
           },
           XMLElementContent={
             .xmlContent(contents, .xmlElementContent)
           },
           XMLSequenceContent={
             .xmlContent(contents, .xmlSequenceContent)
           },
           XMLOrContent={
             .xmlContent(contents, .xmlOrContent)
           },
           stop("Unhandled class:", class(contents), "\n"))
  }
}

.classBuilder <- function(dtd, contains, prefix=character(0),
                          verbose=FALSE) {
  oldwd <- getwd()
  on.exit(setwd(oldwd))
  setwd(dirname(dtd))
  dtd <- XML::parseDTD(basename(dtd))
  for (elt in dtd$elements)
    .xmlElementDef(elt, contains, verbose=verbose, prefix)
  cls <- names(slot(getClass(contains), "subclasses"))
  for (cl in cls) .getters(cl)
}

.buildClasses <- function(classes) {
  if ("DTTCompatibility" %in% classes)
    .classBuilder(system.file("extdata", "MAGE-ML.dtd",
                              package="AffyCompatible"),
                  "DTTCompatibility")
  if ("ARRCompatibility" %in% classes)
    .classBuilder(system.file("extdata", "ArraySetAndTemplateFile.dtd",
                              package="AffyCompatible"),
                  "ARRCompatibility")
  if ("NetAffxCompatibility" %in% classes)
    .classBuilder(system.file("extdata", "NetAffxAnnotFileList.dtd",
                              package="AffyCompatible"),
                  "NetAffxCompatibility", prefix="Affx")
}

.build <- function(pkgname) {
  ## From 'methods' package
  where <- topenv(parent.frame())
  built <-
    if(exists(".builtImage", envir = where, inherits = FALSE))
      get(".builtImage", envir = where)
    else NA
  if(identical(built, FALSE)) {
    on.exit(assign(".builtImage", NA, envir = where))
    .buildClasses(c("DTTCompatibility", "ARRCompatibility",
                    "NetAffxCompatibility"))
    assign(".builtImage", TRUE, envir = where)
    on.exit()
  } else {
    if(!isTRUE(built))
      stop("package ", pkgname, "not installed correctly!")
  }
}

.builtImage <- FALSE

.build("AffyCompatible")

## constructors

.readConstructor <- function(fls, ...) {
    if (length(fls)>1)
        sapply(fls, .readXmlAsClass)
    else
        .readXmlAsClass(fls)[[1]]
}

readMage <- .readConstructor

readArr <- .readConstructor

## show

.AffyCompatible_show <- function(object) {
  for (nm in slotNames(class(object))) {
    val <- slot(object, nm)
    if (!(is(val, ".TypedAssociation") && length(val)==0)) {
        cat(nm, ": ", sep="")
        switch(class(val),
               "character"=cat(noquote(val), "\n"),
               "logical"=cat(noquote(val), "\n"),
               callGeneric(val))
    }
  }
}

setMethod("show",
          signature=signature(object="AffyCompatible"),
          .AffyCompatible_show)
.NetAffxResource_validity <- function(object) {
  msg <- NULL
  slts <- slotNames(getClass("NetAffxResource"))
  len_ok <- sapply(slts, function(slt) {
    elt <- slot(object, slt)
    if (length(elt) == 1) nzchar(elt)
    else FALSE
  })
  if (!all(len_ok))
    msg <- c(msg,
             sprintf("slot(s) '%s' must be length 1, non-empty character vectors",
                     paste(slts[!len_ok], collapse="' '")))
  if (is.null(msg)) TRUE
  else msg
}

setMethod(".validity", "NetAffxResource", .NetAffxResource_validity)

.getters("NetAffxResource")

NetAffxResource <- function(user=character(0), password=character(0),
                            affxLicence=character(0),
                            directory=tempdir(), ...) {
  new("NetAffxResource", ..., user=user, password=password,
      affxLicence=affxLicence, directory=directory)
}

setMethod("names",
          signature=signature(x="NetAffxResource"),
          function(x) {
            .xvalue(.readNetAffxXml(x), "//Array/@name")
          })

.Array_names <- function(x) sapply(affxAnnotation(x), affxDescription)

setMethod("names", signature(x="AffxArray"), .Array_names)

setMethod("affxDescription", signature(x="AffxArray"), .Array_names)

.idxOk <- function(idx, str) {
  len <- length(str)
  if (idx<1 || idx>len)
    stop("'", deparse(substitute(idx)), "' must be >0 and <", len)
  TRUE
}

setMethod("[[",
          signature=signature(
            x="NetAffxResource",
            i="numeric",
            j="missing"),
          function(x, i, j, ...) {
            if (length(i)!=1)
              stop("argument 'i' must be a length 1 vector")
            nms <- names(x)
            .idxOk(i, nms)
            callGeneric(x, i=nms[i], ..., .check=FALSE)
          })

setMethod("[[",
          signature=signature(
            x="NetAffxResource",
            i="character",
            j="missing"),
          function(x, i, j, ..., .check=TRUE) {
            if (.check) {
              if (length(i)!=1)
                stop("argument 'i' must be a length 1 vector")
              if (!i %in% names(x))
                stop("'", i, "' must be in names(x)")
            }
            xclass(.readNetAffxXml(x),
                   paste('//Array[@name="', i, '"]', sep=""),
                   prefix="Affx")[[1]]
          })

.NetAffxResource_descriptions <- function(netAffxResource, name) {
  xpathq <- paste('//Array[@name="', name, '"]//@description', sep="")
  .xvalue(.readNetAffxXml(netAffxResource), xpathq)
}

setMethod("[[",
          signature=signature(
            x="NetAffxResource",
            i="numeric",
            j="numeric"),
          function(x, i, j, ...) {
            if (length(i) != 1 || length(j) != 1)
              stop("arguments 'i', 'j' must be length 1 vectors")
            nms <- names(x)
            .idxOk(i, nms)
            desc <- .NetAffxResource_descriptions(x, nms[i])
            .idxOk(j, desc)
            callGeneric(x, i=nms[i], j=desc[j], ..., .check=FALSE)
          })

setMethod("[[",
          signature=signature(
            x="NetAffxResource",
            i="numeric",
            j="character"),
          function(x, i, j, ...) {
            if (length(i) != 1 || length(j) != 1)
              stop("arguments 'i', 'j' must be length 1 vectors")
            nms <- names(x)
            .idxOk(i, nms)
            callGeneric(x, i=nms[i], j=j, ..., .check=FALSE)
          })

setMethod("[[",
          signature=signature(
            x="NetAffxResource",
            i="character",
            j="numeric"),
          function(x, i, j, ...) {
            if (length(i) != 1 || length(j) != 1)
              stop("arguments 'i', 'j' must be length 1 vectors")
            desc <- .NetAffxResource_descriptions(x, i)
            .idxOk(j, desc)
            callGeneric(x, i, j=desc[j], ..., .check=FALSE)
          })

setMethod("[[",
          signature=signature(
            x="NetAffxResource",
            i="character",
            j="character"),
          function(x, i, j, ..., .check=TRUE) {
            if (.check) {
              if (length(i) != 1 || length(j) != 1)
                stop("arguments 'i', 'j' must be length 1 vectors")
              if (!i %in% names(x))
                stop("'", i, "' must be in names(x)")
              desc <- .NetAffxResource_descriptions(x, i)
              idx <- match(j, desc)
              if (is.na(idx))
                stop("arugment j ('", j, "') must be one of '",
                     paste(desc, collapse="', '"), "'")
            }
            xpathq <-
              paste("/NetAffxAnnotFileList/Array[@name='", i, "']",
                    "/Annotation[@description='", j, "']",
                    sep="")
            xclass(.readNetAffxXml(x), xpathq, prefix="Affx")[[1]]
          })

.NetAffxResource_show <- function(object) {
  for (nm in slotNames(class(object))) {
    val <- 
      if (nm %in% c("password", "affxLicence")) rep("*", 8)
      else slot(object, nm)
    cat(nm, ": ", val, "\n", sep="")
    invisible()
  }
}

setMethod("show",
          signature=signature(object="NetAffxResource"),
          .NetAffxResource_show)

.netAffxUrl <- function(x) {
  paste(affxUrl(x), "?", "licence=", affxLicence(x), "&",
        "user=", user(x), "&", "password=", password(x), sep="")
}

## Annotation file list

.netAffxAnnotListFile <- function(x) {
  file.path(directory(x), annotationsFile(x))
}

.retrieveNetAffx <- function(netAffxResource, update, ...) {
  annotFile <- .netAffxAnnotListFile(netAffxResource)
  if (update || !file.exists(annotFile)) {
    url <- .netAffxUrl(netAffxResource)
    .opts <- curlOptions(ssl.verifypeer=FALSE)
    rsrc <- getURL(url, .opts=.opts)
    tmpfile <- tempfile()
    cat(rsrc, file=tmpfile) # save to file; XML 1.93 fails to parse long first args
    status <- .xvalue(readXml(tmpfile), "/NetAffxAnnotFileList/Status")
    if (nzchar(status)) {
      unlink(tmpfile)
      stop("NetAffxResource: ", status)
    }
    file.rename(tmpfile, annotFile)
    unlink(tmpfile)
  }
  annotFile
}

readNetAffx <- function(netAffxResource, update=FALSE, ...) {
  annotFile <- .retrieveNetAffx(netAffxResource, update, ...)
  .readXmlAsClass(annotFile, prefix="Affx")[[1]]
}

.readNetAffxXml <- function(netAffxResource, update=FALSE, ...) {
  annotFile <- .retrieveNetAffx(netAffxResource, update, ...)
  readXml(annotFile)
}

## Annotations per se

setGeneric("readAnnotation",
           function(netAffxResource, array, annotation, ...) {
             standardGeneric("readAnnotation")
           })

.readAnnotation2 <- function(netAffxResource, array, annotation, ...) {
  .readAnnotation(netAffxResource, netAffxResource[[array, annotation]],
                  ...)
}

setMethod("readAnnotation",
          signature=signature(
            netAffxResource="NetAffxResource",
            array="character",
            annotation="character"),
          .readAnnotation2)

setMethod("readAnnotation",
          signature=signature(
            netAffxResource="NetAffxResource",
            array="character",
            annotation="numeric"),
          .readAnnotation2)

setMethod("readAnnotation",
          signature=signature(
            netAffxResource="NetAffxResource",
            array="numeric",
            annotation="character"),
          .readAnnotation2)

setMethod("readAnnotation",
          signature=signature(
            netAffxResource="NetAffxResource",
            array="numeric",
            annotation="numeric"),
          .readAnnotation2)

setMethod("readAnnotation",
          signature=signature(
            netAffxResource="NetAffxResource",
            array="missing",
            annotation="AffxAnnotation"),
          function(netAffxResource, array, annotation, ...) {
            .readAnnotation(netAffxResource, annotation, ...)
          })

.netAffxAnnotFile <- function(netAffxResource, url) {
  file.path(directory(netAffxResource), basename(url))
}

.readAnnotation <- function(netAffxResource, annotation, fileIndex=1,
                            ..., content=TRUE, update=FALSE) {
  affxUrl <- affxUrl(affxFile(annotation)[[fileIndex]])[[1]]
  url <- .Data(affxUrl)
  annotFile <- .netAffxAnnotFile(netAffxResource, url)
  if (update || !file.exists(annotFile)) {
    download.file(url, annotFile, mode="wb")
  }
  if (!content)
    return(annotFile)
  conn <- 
    switch(affxCompression(affxUrl),
           "application/zip"={
             fileName <- sub(".zip$", "", basename(annotFile))
             if (length(grep("_psi$", fileName))>0)
               fileName <- sub("_psi$", ".psi", fileName)
             unz(annotFile, fileName)
           },
           stop("unknown affxCompression:", affxCompression(affxUrl)))
  on.exit(unlink(fileName))
  res <-
    switch(sub(".* ", "", affxType(annotation)),
           CSV=read.csv(conn),
           Tabular=read.delim(conn),
           FASTA=readFASTA(conn),
           PSI=read.delim(conn, header=FALSE, skip=1, sep="\t"),
           {
             close(conn)
             message("returning path to file of affxType '",
                     affxType(annotation), "'")
             annotFile
           })
  res
}
xmlValue.XMLAttributeValue <-
    function(x, ignoreComments=FALSE)
{
    as.character(x)
}
