.packageName <- "SNPtools"

.SNPperBaseURL <- "http://snpper.chip.org/bio/rpcserv/dummy?cmd="

.rpcCalls <- list(
 "showcalls"=NULL,
 "genelayout"=list(args="id",
    comment="SNPper gene id, use 'geneinfo' to determine"),
 "geneinfo"=list(args=c("name", "acc", "id"), comment=
     "acc: mRNA accession no., id=SNPper id"),
 "snpinfo"=list(args="id", comment="number after rs in dbSNP id"),
 "snpsetinfo"=list(args="name", comment="SNPper generated set name"),
 "genesinrange"=list(args=c("chr", "s", "e"), 
   comment="chromosome no., start, end"),
 "snpsinrange"=list(args=c("chr", "s", "e"), 
   comment="chromosome no., start, end"),
 "genesnps"=list(args=c("id", "acc", "sub"), 
   comment="SNPper id, mRNA acc, or submitter"),
 "countsnps"=list(args=c("chr", "s", "e"), 
   comment="chromosome no., start, end"))

geneInfo <- function (name = NA, acc = NA, id = NA) 
{
    require("XML")
    if (all(ng <- is.na(c(name, acc, id)))) 
        stop("must request info on some gene")
    if (sum(ng) != 2) 
        stop("please use only one gene id")
    parms <- c("name", "acc", "id")
    vals <- c(name, acc, id)
    ok <- (1:3)[ng == FALSE]
    suff <- paste("geneinfo&", parms[ok], "=", vals[ok], sep = "")
    Url <- paste(.SNPperBaseURL, suff, sep = "")
Url <- url(Url)
on.exit(close(Url))
    if (libxmlVersion()$major == 1) {
        data <- paste(scan(Url, "", quiet=TRUE), collapse = " ")
        xmlEventParse(data, ginfoHandler(), asText = TRUE)$dump()
    }
    else xmlEventParse(paste(readLines(Url),collapse=" "), ginfoHandler(), asText=TRUE)$dump()
}

geneLayout <- function (id = NA) 
{
    require("XML")
    if (is.na(id))
        stop("must request info on some gene")
    if (length(id)>1) stop("not vectorized at present, request only 1 id")
    suff <- paste("genelayout&", "id=", id, sep = "")
    Url <- paste(.SNPperBaseURL, suff, sep = "")
Url <- url(Url)
on.exit(close(Url))
    if (libxmlVersion()$major == 1) {
        data <- paste(scan(Url, "", quiet=TRUE), collapse = " ")
        xmlEventParse(data, glayHandler(), asText = TRUE)$dump()
    }
    else xmlEventParse(paste(readLines(Url),collapse=""), glayHandler(), asText=TRUE)$dump()
}

SNPinfo <- function (dbsnpid = NA) 
{
    require("XML")
    id <- dbsnpid
    if (is.na(id))
        stop("must request info on some SNP")
    if (length(id)>1) stop("not vectorized at present, request only 1 id")
    suff <- paste("snpinfo&", "id=", id, sep = "")
    Url <- paste(.SNPperBaseURL, suff, sep = "")
Url <- url(Url)
on.exit(close(Url))
    if (libxmlVersion()$major == 1) {
        data <- paste(scan(Url, "", quiet=TRUE), collapse = " ")
        xmlEventParse(data, snpinfoHandler(), asText = TRUE)$dump()
    }
    else xmlEventParse(paste(readLines(Url),collapse=""), snpinfoHandler(),
            asText=TRUE)$dump()
}

geneSNPs <- function (id = NA, acc=NA) 
{
    require("XML")
    if (!is.na(id) & !is.na(acc)) warning("both id and acc supplied, using id")
    if (length(id)>1) stop("not vectorized at present, request only 1 id")
    if (length(acc)>1) stop("not vectorized at present, request only 1 acc")
    if (!is.na(id))suff <- paste("genesnps&", "id=", id, sep = "")
    if (!is.na(acc))suff <- paste("genesnps&", "acc=", acc, sep = "")
    Url <- paste(.SNPperBaseURL, suff, sep = "")
Url <- url(Url)
on.exit(close(Url))
    if (libxmlVersion()$major == 1) {
        data <- paste(scan(Url, "", quiet=TRUE), collapse = " ")
        xmlEventParse(data, sinrangeHandler(), asText = TRUE)$dump()
    }
    else xmlEventParse(paste(readLines(Url),collapse=""), sinrangeHandler(),
            asText=TRUE)$dump()
}

itemsInRange <- function (item="genes", chr, start, end)
{
    require("XML")
    if (is.numeric(start)) stop("please supply start and end as strings")
    if (is.numeric(end)) stop("please supply start and end as strings")
    if (length(chr)>1) stop("not vectorized at present, request only 1 id")

if (item == "genes") {cmd <- "genesinrange"; han <- ginrangeHandler}
else if (item == "snps") {cmd <- "snpsinrange"; han <- sinrangeHandler}
#else if (item == "nsnps"|item=="countsnps") {cmd <- "countsnps"; han <- nsnpHandler}
else if (item == "nsnps"|item=="countsnps") 
   {
#   warning("countsnps command not returning valid "XML", using string parsing")
   cmd <- "countsnps"
   }
else stop("item must be 'genes' or 'snps' or 'countsnps'")

if (item != "nsnps" & item != "countsnps")
    suff <- paste(cmd, "&chr=", chr,
            "&s=", start, "&e=", end, sep = "")
else
    suff <- paste(cmd, "&chr=", chr,
            "&start=", start, "&end=", end, sep = "")
    Url <- paste(.SNPperBaseURL, suff, sep = "")
Url <- url(Url)
on.exit(close(Url))
#
# following is a patch-up because "XML" parsing fails with countsnps
# command (chip returns a tag with slashes in it)
#
if (item == "nsnps"|item=="countsnps") 
        {
        data <- paste(scan(Url, "", quiet=TRUE), collapse = " ")
#print(data) -- shows some inconsistency in RPC response from chip
# parsing below seems OK
        ind <- regexpr("NON.*TOT",data)
        rem <- substr(data,ind+7,50000)
        r2 <- regexpr("<",rem)
        rem <- substr(rem,1,r2-1)
        tmp <- as.numeric(strsplit(rem,"/")[[1]][1:3])
        names(tmp) <- c("total","exonic","nonsyn")
        return(tmp)
        }
else
    if (libxmlVersion()$major == 1) {
        data <- paste(scan(Url, "", quiet=TRUE), collapse = " ")
        xmlEventParse(data, han(), asText = TRUE)$dump()
    }
    else xmlEventParse(paste(readLines(Url),collapse=""), han(),
            asText=TRUE)$dump()
}

outPaste <- function (x, y) 
as.character(outer(x, y, function(x, y) paste(x, y, sep = ".")))

dot <- function(x,y) paste(x,y,sep=".")

ginfoHandler <- function() {
 toolInfo <- NULL
 snppergid <- NULL
#
# setup for flat text info
#
 txtTags <- c("NAME", "CHROM", "STRAND", "PRODUCT",
        "LOCUSLINK", "OMIM", "UNIGENE",
	"SWISSPROT", "NSNPS", "REFSEQACC", "MRNAACC")
 status <- rep(FALSE,length(txtTags))
 atoms <- rep(" ",length(txtTags))
 names(status) <- txtTags
 names(atoms) <- txtTags
#
# setup for depth 1 info
#
 curCon <- NULL
 curConTag <- NULL
 contextTags <- c("TRANSCRIPT","CODINGSEQ")
 d1Tags <- c("START", "END")
 d1vals <- rep(" ", length(contextTags)*length(d1Tags))
 d1names <- outPaste(contextTags,d1Tags)
 names(d1vals) <- d1names
 startElement = function(x, atts, ...)
  {
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- TRUE
  else if (x == "SNPPER-RPC")
    toolInfo <<- atts
  else if (x == "GENE")
    {
    snppergid <<- atts
    names(snppergid) <<- "snpper.ID"
    }
  else if (x %in% contextTags)
    curCon <<- x
  else if (x %in% d1Tags)
    {
    curConTag <<- dot(curCon,x)
    }
  }
 endElement = function(x, ...) {
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- FALSE
  else if (x %in% contextTags)
    curCon <<- NULL
  }
 text = function(x, atts, ...) {
  if (any(status)) atoms[status==TRUE] <<- x # careful with elses!
  if (!is.null(curConTag) && !is.na(match(curConTag,d1names)))
       {
       d1vals[curConTag] <<- x
       curConTag <<- NULL
       }
  }
 dump = function() {
  obj <- c(snppergid,atoms,d1vals)
  attr(obj,"toolInfo") <- toolInfo
  obj
 }
 list(startElement=startElement, endElement=endElement, text=text,
       dump=dump)
}
 
useSNPper2 <- function (cmd, parmstring) 
readLines(paste(.SNPperBaseURL, cmd, parmstring, sep = ""))

useSNPper <- function (cmd, parmstring) 
{
targ <- url(paste(.SNPperBaseURL, cmd, parmstring, sep = ""))
open(targ)
on.exit(close(targ))
readLines(targ)
}

glayHandler <- function() {
 toolInfo <- NULL
#
# setup for flat text info
#
 txtTags <- c("ID", "NAME", "CHROM")
 status <- rep(FALSE,length(txtTags))
 atoms <- rep(" ",length(txtTags))
 names(status) <- txtTags
 names(atoms) <- txtTags
#
# setup for depth 1 info
#
 curCon <- NULL
 curConTag <- NULL
 contextTags <- c("TRANSCRIPT","CODINGSEQ")
 d1Tags <- c("START", "END")
 d1vals <- rep(" ", length(contextTags)*length(d1Tags))
 d1names <- outPaste(contextTags,d1Tags)
 names(d1vals) <- d1names
#
# variable length data on exons!
#
 inExon <- FALSE
 curex <- 0
 ies <- FALSE
 iee <- FALSE
 elist <- list()
#
#
#
 startElement = function(x, atts, ...)
  {
  if (x == "EXON")
    {
    inExon <<- TRUE
    curex <<- curex+1
    }
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- TRUE
  else if (x == "SNPPER-RPC")
    toolInfo <<- atts
  else if (x %in% contextTags)
    curCon <<- x
  else if (x %in% d1Tags)
    {
    curConTag <<- dot(curCon,x)
    if (inExon & x=="START") ies <<- TRUE
    if (inExon & x=="END") iee <<- TRUE
    }
  }
 endElement = function(x, ...) {
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- FALSE
  else if (x %in% contextTags)
    curCon <<- NULL
  else  if (inExon & x=="START") ies <<- FALSE
  else  if (inExon & x=="END") iee <<- FALSE
  else if (x == "EXON")
    inExon <<- FALSE
  }
 text = function(x, atts, ...) {
  if (any(status)) atoms[status==TRUE] <<- x # careful with elses!
  if (!is.null(curConTag) && !is.na(match(curConTag,d1names)))
       {
       d1vals[curConTag] <<- x
       curConTag <<- NULL
       }
  if (ies) 
    {
    elist[[curex]] <<- rep(NA,2)
    pre <- paste("exon",curex,sep="")
    names(elist[[curex]]) <<- paste(pre,c("start", "end"),sep=".")
    elist[[curex]][1] <<- x
    }
  if (iee)
    elist[[curex]][2] <<- x
  }
 dump = function() {
  obj <- c(atoms,d1vals,unlist(elist))
  attr(obj,"toolInfo") <- toolInfo
  obj
 }
 list(startElement=startElement, endElement=endElement, text=text,
       dump=dump)
}

snpinfoHandler <- function() {
 toolInfo <- NULL
#
# setup for flat text info
#
 txtTags <- c("DBSNPID", "TSCID", "CHROMOSOME",
   "POSITION", "ALLELES", "ROLE", "RELPOS", "AMINO",
   "AMINOPOS")
 status <- rep(FALSE,length(txtTags))
 atoms <- rep(" ",length(txtTags))
 names(status) <- txtTags
 names(atoms) <- txtTags
#
# setup for depth 1 info
#
 contextTags <- c("TRANSCRIPT","CODINGSEQ")
 d1Tags <- c("START", "END")
 d1vals <- rep(" ", length(contextTags)*length(d1Tags))
 d1names <- outPaste(contextTags,d1Tags)
 names(d1vals) <- d1names
#
# attribute data on gene
#
 gdata <- NULL
#
#
#
 startElement = function(x, atts, ...)
  {
  if (x == "GENE")
    gdata <<- atts
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- TRUE
  else if (x == "SNPPER-RPC")
    toolInfo <<- atts
  }
 endElement = function(x, ...) {
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- FALSE
  }
 text = function(x, atts, ...) {
  if (any(status)) atoms[status==TRUE] <<- x # careful with elses!
  }
 dump = function() {
  obj <- c(atoms,gdata)
  attr(obj,"toolInfo") <- toolInfo
  obj
 }
 list(startElement=startElement, endElement=endElement, text=text,
       dump=dump)
}

ginrangeHandler <- function() {
 toolInfo <- NULL
#
# setup for flat text info
#
 txtTags <- c("NAME", "CHROM", "PRODUCT", "NSNPS")
 status <- rep(FALSE,length(txtTags))
 atoms <- rep(" ",length(txtTags))
 names(status) <- txtTags
 names(atoms) <- txtTags
#
# setup for depth 1 info
#
 contextTags <- c("TRANSCRIPT","CODINGSEQ")
 d1Tags <- c("START", "END")
 d1vals <- rep(" ", length(contextTags)*length(d1Tags))
 d1names <- outPaste(contextTags,d1Tags)
 names(d1vals) <- d1names
#
# attribute data on genesinrange
#
 gdata <- NULL
#
#
#
 glist <- list()
 curg <- 1
 startElement = function(x, atts, ...)
  {
  if (x == "GENESINRANGE")
    gdata <<- atts
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- TRUE
  else if (x == "SNPPER-RPC")
    toolInfo <<- atts
  }
 endElement = function(x, ...) {
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- FALSE
  if (x == "GENE")
    {
    glist[[curg]] <<- atoms
    atoms[1:length(atoms)] <<- " "
    curg <<- curg+1
    }
  }
 text = function(x, atts, ...) {
  if (any(status)) atoms[status==TRUE] <<- x # careful with elses!
  }
 dump = function() {
  obj <- c(glist,gdata)
  attr(obj,"toolInfo") <- toolInfo
  obj
 }
 list(startElement=startElement, endElement=endElement, text=text,
       dump=dump)
}

sinrangeHandler <- function() {
#
# also works for genesnps call
#
 toolInfo <- NULL
#
# setup for flat text info
#
 txtTags <- c("DBSNPID", "TSCID", "CHROMOSOME",
   "POSITION", "ALLELES", "ROLE", "RELPOS", "AMINO",
   "AMINOPOS")
 status <- rep(FALSE,length(txtTags))
 atoms <- rep(" ",length(txtTags))
 names(status) <- txtTags
 names(atoms) <- txtTags
#
# setup for depth 1 info
#
 contextTags <- c("TRANSCRIPT","CODINGSEQ")
 d1Tags <- c("START", "END")
 d1vals <- rep(" ", length(contextTags)*length(d1Tags))
 d1names <- outPaste(contextTags,d1Tags)
 names(d1vals) <- d1names
#
# attribute data on snps
#
 gdata <- NULL
#
# annotation
 adata <- NULL
#
#
#
 snpl <- list()
 curel <- 1
 startElement = function(x, atts, ...)
  {
  if (x == "SNPSINRANGE" | x == "GENESNPS")
    gdata <<- atts
  if (x == "GENE")
    adata <<- atts
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- TRUE
  else if (x == "SNPPER-RPC")
    toolInfo <<- atts
  }
 endElement = function(x, ...) {
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- FALSE
  if (x == "SNPINFO")
    {
    snpl[[curel]] <<- c(atoms,adata)
    atoms[1:length(atoms)] <<- " "
    curel <<- curel+1
    }
  }
 text = function(x, atts, ...) {
  if (any(status)) atoms[status==TRUE] <<- x # careful with elses!
  }
 dump = function() {
  obj <- c(snpl,gdata)
  attr(obj,"toolInfo") <- toolInfo
  obj
 }
 list(startElement=startElement, endElement=endElement, text=text,
       dump=dump)
}

nsnpHandler <- function() {
 toolInfo <- NULL
#
# setup for flat text info
#
 txtTags <- c("TOTAL/EXONIC/NONSYN")
 status <- rep(FALSE,length(txtTags))
 atoms <- rep(" ",length(txtTags))
 names(status) <- txtTags
 names(atoms) <- txtTags
#
# setup for depth 1 info
#
 contextTags <- c("TRANSCRIPT","CODINGSEQ")
 d1Tags <- c("START", "END")
 d1vals <- rep(" ", length(contextTags)*length(d1Tags))
 d1names <- outPaste(contextTags,d1Tags)
 names(d1vals) <- d1names
#
# attribute data on gene
#
 gdata <- NULL
#
#
#
 startElement = function(x, atts, ...)
  {
  if (x == "GENE")
    gdata <<- atts
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- TRUE
  else if (x == "SNPPER-RPC")
    toolInfo <<- atts
  }
 endElement = function(x, ...) {
  if (x %in% txtTags)
    status[match(x,txtTags)] <<- FALSE
  }
 text = function(x, atts, ...) {
  if (any(status)) atoms[status==TRUE] <<- x # careful with elses!
  }
 dump = function() {
  obj <- c(atoms,gdata)
  attr(obj,"toolInfo") <- toolInfo
  obj
 }
 list(startElement=startElement, endElement=endElement, text=text,
       dump=dump)
}

.First.lib <- function(libname, pkgname, where) {
    require("methods")
    require("XML")
#    where <- match(paste("package:", pkgname, sep=""), search())
#    .initSNPset(where)
#    .initGeneInfo(where)
#    .initChromSNPs(where)
#    .poutClasses(where)
#    cacheMetaData(as.environment(where))
}
