.packageName <- "HSAUR"

Rwelcome <- function() {

    tversion <- paste(version$major, version$minor, sep = ".")
    tdate <- paste(version$year, version$month, version$day, sep = "-") 
    x <- c(paste("R : Copyright", version$year, "The R Foundation for Statistical Computing"),
           paste("Version", tversion, paste("(", tdate, "),", sep = ""), 
                 "ISBN 3-900051-07-0"),
           " ",
           "R is free software and comes with ABSOLUTELY NO WARRANTY.",
           "You are welcome to redistribute it under certain conditions.",
           "Type 'license()' or 'licence()' for distribution details.",
           " ",
           "R is a collaborative project with many contributors.",
           "Type 'contributors()' for more information and",
           "'citation()' on how to cite R or R packages in publications.",
           " ",
           "Type 'demo()' for some demos, 'help()' for on-line help, or",
           "'help.start()' for an HTML browser interface to help.",
           "Type 'q()' to quit R.\n")
    cat(paste(x, collapse = "\n"))
}

exename <- function() {

    tversion <- paste(version$major, "0", substr(version$minor, 1, 1),
                      substr(version$minor,3,3), sep = "")
    return(paste("rw", tversion, ".exe", sep = ""))
}

HSAURcite <- function(pkg) {
    ct <- citation(pkg)
    attr(ct, "label") <- paste("PKG:", pkg, sep = "", collapse = "")
    for (n in c("note"))
        ct[[n]] <- gsub("R", "\\R{}", ct[[n]])
    class(ct) <- "HSAURcitation"
    return(ct)
}

toBibtex.HSAURcitation <-  function (object, ...) 
{
    z <- paste("@", attr(object, "entry"), "{", attr(object, "label"), 
               ",", sep = "")
    if ("author" %in% names(object)) {
        object$author <- toBibtex(object$author)
    }
    for (n in names(object)) z <- c(z, paste("  ", n, " = {", 
        object[[n]], "},", sep = ""))
    z <- c(z, "}")
    class(z) <- "Bibtex"
    z
}

isep <- function(x)
    paste(paste(x[-length(x)], "&", collapse = " "), 
          x[length(x)], collapse = " ")

caption <- function(xname, label, caption, pkg = NULL) {
    RET <- paste("\\caption{\\Robject{", xname, "} data", 
                 sep = "", collapse = "")
    if (!is.null(pkg))
        RET <- paste(RET, " (package \\Rpackage{", pkg, "})", 
                     sep = "", collapse = "")
    RET <- paste(RET, ". ", caption, sep = "", collapse = "")
    RET <- paste(RET, paste("\\label{", label, "}}", 
                 sep = "", collapse = ""))
    return(RET)
}


HSAURtable <- function(object, ...)
    UseMethod("HSAURtable")

HSAURtable.data.frame <- function(object, xname = deparse(substitute(object)),
                                  pkg = NULL, nrows = NULL,...) {

    digits <- 0:6
    table <- matrix("0", nrow = nrow(object), ncol = ncol(object))
    xcc <- object[complete.cases(object),]
    for (i in 1:ncol(object)) {
        if (is.numeric(xcc[[i]])) {
            d <- min(which(sapply(digits, 
                function(d) 
                    max(abs(xcc[[i]] - round(xcc[[i]], d))) < 
                            sqrt(.Machine$double.eps))))
            table[,i] <- formatC(object[[i]], digits = digits[d], format = "f")
        } else {
            table[,i] <- as.character(object[[i]])
        }
    }
    if (!is.null(nrows)) table <- rbind(table[1:nrows,,drop = FALSE], "$\\vdots$")

    RET <- list(xname = xname,
                pkg = pkg, 
                varnames = colnames(object),
                rownames = rownames(object),
                data = table)
    class(RET) <- "dftab"
    return(RET)
}

HSAURtable.table <- function(object, xname = deparse(substitute(object)),
                             pkg = NULL,...) {

    xtab <- matrix(as.character(object), nrow = nrow(object), 
                   ncol = ncol(object))
    RET <- list(xname = xname,
                pkg = pkg,
                varnames = names(dimnames(object)),
                data = rbind(c(" ", dimnames(object)[[2]]),
                             cbind(dimnames(object)[[1]], xtab)))
    class(RET) <- "tabtab"
    return(RET)
}

toLatex.tabtab <- function(object, caption = NULL, label = NULL, 
                           topcaption = TRUE, index = TRUE, ...) {

    RET <- c()
    nc <- ncol(object$data)

    if (index)
        RET <- c(RET, paste("\\index{", object$xname, " data@\\Robject{",
                            object$xname, "} data}", sep = ""))

    RET <- c(RET, "\\begin{center}")

    RET <- c(RET, paste("\\begin{longtable}",
        paste("{", paste(rep("r", nc + 1), collapse = ""), "}")))
    if (topcaption)
        RET <- c(RET, caption(object$xname, label, caption, object$pkg),
                 "\\\\")
    RET <- c(RET, paste(" & & \\multicolumn{", nc - 1, "}{c}{\\Robject{", 
              object$varnames[2], "}} \\\\", collapse = ""))
    object$data <- cbind(c(paste("\\Robject{", object$varnames[1], "}", 
                                 collapse = ""), 
                           rep(" ", nrow(object$data) - 1)), object$data)
    RET <- c(RET,  apply(object$data, 1, function(x) paste(isep(x), "\\\\"))) 
    if (!topcaption)
        RET <- c(RET, caption(object$xname, label, caption, object$pkg))
    RET <- c(RET, "\\end{longtable}")
    RET <- c(RET, "\\end{center}")
    class(RET) <- "Latex"
    return(RET)
}


toLatex.dftab <- function(object, pcol = 1, caption = NULL, 
    label = NULL, rownames = FALSE, topcaption = TRUE, index = TRUE, ...) {
    
    nc <- ncol(object$data)

    if (pcol > 1) {
        nr <- ceiling(nrow(object$data) / pcol)
        object$data <- rbind(object$data, matrix(" ", 
            nrow = nr * pcol - nrow(object$data), 
            ncol = nc))
        d <- NULL
        for (i in 1:pcol)
            d <- cbind(d, object$data[((i - 1) * nr + 1):(i * nr),])
        object$data <- d       
    }

    RET <- c()

    if (index)
        RET <- c(RET, paste("\\index{", object$xname, " data@\\Robject{",
                            object$xname, "} data}", sep = ""))

    RET <- c(RET, "\\begin{center}")
    if (rownames) 
        RET <- c(RET, 
            paste("\\begin{longtable}{l", paste(rep(paste(rep("r", nc), 
                                                          collapse = ""), pcol), 
                                                collapse = "|"), "}", 
                  collapse = ""))
    else 
        RET <- c(RET, 
            paste("\\begin{longtable}{", paste(rep(paste(rep("r", nc), 
                                                         collapse = ""), pcol), 
                                              collapse = "|"), "}", 
                  collapse = ""))
    if (topcaption)
        RET <- c(RET, caption(object$xname, label, caption, object$pkg),
                 "\\\\")
    RET <- c(RET, "\\hline")
    vn <- rep(object$varnames, pcol)
    vn <- paste(paste("\\Robject{", vn, sep = ""), "}", sep = "")
    if (rownames) {
        RET <- c(RET, paste("  & ", isep(vn), "\\\\ \\hline"))
        RET <- c(RET, "\\endfirsthead")
        RET <- c(RET, paste("\\caption[]{\\Robject{", object$xname, 
                            "} data (continued).} \\\\", 
                 sep = "", collapse = ""))
        RET <- c(RET, "\\hline")
        RET <- c(RET, paste("  & ", isep(vn), "\\\\ \\hline"))
        RET <- c(RET, "\\endhead")
        for (i in 1:nrow(object$data))
            RET <- c(RET, paste(object$rownames[i], "  & ", 
                                isep(object$data[i,]), "\\\\"))
    } else {
        RET <- c(RET, paste(isep(vn), "\\\\ \\hline"))
        RET <- c(RET, "\\endfirsthead")
        RET <- c(RET, paste("\\caption[]{\\Robject{", object$xname, 
                            "} data (continued).} \\\\", sep = "", collapse = ""))
        RET <- c(RET, "\\hline")
        RET <- c(RET, paste(isep(vn), "\\\\ \\hline"))
        RET <- c(RET, "\\endhead")
        RET <- c(RET, 
            apply(object$data, 1, function(x) paste(isep(x), "\\\\")))
    }
    RET <- c(RET, "\\hline")
    if (!topcaption)
        RET <- c(RET, caption(object$xname, label, caption, object$pkg))
    RET <- c(RET, "\\end{longtable}")
    RET <- c(RET, "\\end{center}")
    class(RET) <- "Latex"
    return(RET)
}


### some tools that make life easier

### copy *Rout to *Rout.save
cpRoutsave <- function(Routdir = NULL, Routsavedir = NULL) {

    Routfiles <- list.files(path = Routdir, pattern = "\.Rout$", 
                            full.names = FALSE)
    srcfiles <- file.path(Routdir, Routfiles)
    destfiles <- file.path(Routsavedir, 
                           paste(Routfiles, ".save", sep = ""))
    file.copy(srcfiles, destfiles, overwrite = TRUE)
}

### attach all data frames in the global environment
gattach <- function() {

    env <- globalenv()
    var <- eval(parse(text = "ls()"), envir = env)
    df <- sapply(var, function(x)
        eval(parse(text = 
            paste("is.data.frame(", x, ")", sep = "", collapse = "")), 
            envir = env))
    if (any(df)) {
      var <- var[df]
      out <- sapply(var, function(x) 
          eval(parse(text = 
              paste("attach(", x, ")", sep = "", collapse = "")),
              envir = env))
    }
}


### extract and check Robject or Rcmd LaTeX markup
extRact <- function(file, what = "Robject") {

    x <- readLines(file)
    indx <- grep(what, x)
    
    out <- sapply(indx, function(i) {
        obj <- NULL
        while (TRUE) {
            where <- regexpr(what, x[i])
            if (where != -1) {
                x[i] <- substring(x[i], where)
                dm <- tools:::delimMatch(x[i])
                obj <- c(obj, (substring(x[i], dm + 1, 
                         dm + attr(dm, "match.length") - 2)))
                x[i] <- substring(x[i], dm + attr(dm, "match.length"))
            } else {
                break
            }
        }
        return(obj)
    })
    cmds <- unique(gsub("\\\\", "", out))
    gattach()
    for (cmd in cmds) {
        a <- try(eval(parse(text = cmd)))
        if (class(a) == "try-error") print(a)
    }
    cmds
}

### try to polish S{in,out}put environments, this needs
### manual refinements in some places
prettyS <- function(file, texenvironment = c("Sinput", "Soutput"), 
                    width = 63, split = " ", write = TRUE) {

    ### handle Sinput or Soutput environments
    texenvironment <- match.arg(texenvironment)
    if (texenvironment == "Sinput" && split == " ")
        split <- c(", ", "/", " ")

    ### dirty hack: in `Makefile's I want to call `prettyS'
    ### right after weaving and thus have only `file.Rnw' available
    if (length(grep("Rnw\$", file)) > 0) file <- gsub("Rnw\$", "tex", file)

    ### read file
    x <- readLines(file)

    ### remove all end-line spaces
    x <- gsub(" \$", "", x)

    ### determine begin and end lines of environment
    start <- grep(paste("^\\\\begin\\{", texenvironment, "\\}\$", 
                  sep = "", collapse = ""), x)
    end <- grep(paste("^\\\\end\\{", texenvironment, "\\}\$", 
                  sep = "", collapse = ""), x)
    if (length(start) == 0) return(NULL)
    if (length(start) != length(end)) 
        stop("unbalanced begin and end statements")
    n <- length(start)

    for (i in 1:n) {
  
        ### iterate over all lines longer than width
        lines <- (start[i]):(end[i])
        lines <- lines[sapply(x[lines], nchar) > width]
        for (line in lines) {
            cat("prettyS: line ", line, " too long: \n", x[line], "\n")
            y <- x[line]
            add <- sapply(split, function(s) 
                ifelse(length(grep(s, y)) > 0, nchar(s), 0))
            if (all(add == 0)) next()
            s <- split[min(which(add > 0))]
            y <- unlist(strsplit(y, split = s))
            nc <- sapply(y, nchar) + add[min(which(add > 0))]
            pos <- cumsum(nc) <= width
            if (!any(pos)) next()
            newline <- cumsum(nc)[max(which(pos))]
            plus <- length(grep("^\\+", x[line])) > 0 && 
                    substr(x[line], newline - 1, newline) != ", "
            x[line] <- paste(substr(x[line], 1, newline), "\n",
                ifelse(texenvironment == "Sinput", options("continue"), ""),
                ifelse(plus, "    ", ""),
                "    ",
                substr(x[line], newline + 1, nchar(x[line])), sep = "", 
                collapse = "")
#            if (length(grep("^\\+", x[line + 1])) > 0 && 
#                (nchar(x[line + 1]) + (nchar(x[line]) - newline) < width)) {
#                y <- x[line + 1]
#                y <- gsub("^\\+   ", "", y)
#                x[line] <- paste(x[line], y, sep = "", collapse = "")
#                x[line + 1] <- ""
#            }
             cat("prettyS: ", x[line], "\n")
        }
    }
    if (write)
        writeLines(x, con = file)
}

### extract all Sinput environments from tex files
chkS <- function(file) {

    texenvironment <- "Sinput"

    ### read file
    x <- readLines(file)

    ### determine begin and end lines of environment
    start <- grep(paste("^\\\\begin\\{", texenvironment, "\\}\$", 
                  sep = "", collapse = ""), x)
    end <- grep(paste("^\\\\end\\{", texenvironment, "\\}\$", 
                  sep = "", collapse = ""), x)
    if (length(start) == 0) return(NULL)
    if (length(start) != length(end)) 
        stop("unbalanced begin and end statements")
    n <- length(start)

    y <- NULL

    for (i in 1:n) {
  
        ### iterate over all lines longer than width
        lines <- (start[i] + 1):(end[i] - 1)
        x[lines] <- gsub("^R>", "", x[lines])
        x[lines] <- gsub("^\\+", "", x[lines])
        y <- c(y, x[lines])

    }
    y
}


### read in a BibTeX file and return as list
readBibtex <- function(file = NULL) {

    bib <- readLines(file)

    entries <- grep("^@", bib)
    labels <- gsub(",\$", "", gsub("^\@[A-Za-z].*\\{", "", bib[entries]))

    if (any(duplicated(labels))) {
        print(labels[duplicated(labels)])
        stop("non-unique BibTeX labels in ", file)
    }

    biblist <- vector(mode = "list", length = length(entries))

    for (i in 1:length(entries)) {
        nexte <- ifelse(i == length(entries), length(entries), 
                        entries[i + 1] - 1)
        biblist[[i]] <- bib[entries[i]:nexte]
        empty <- grep("^\$", biblist[[i]])
        if (length(empty) > 0)
        biblist[[i]] <- biblist[[i]][-empty]
    }
    names(biblist) <- labels
    class(biblist) <- "txtBibtex"
    return(biblist)
}

### the subset of a BibTeX database actually used in `file'
extractBibtex <- function(file, bibtex) {

    if (class(bibtex) != "txtBibtex")
        bibtex <- readBibtex(bibtex)
    tex <- readLines(file)
    tex <- tex[grep("\\cite", tex)]
    enames <- gsub("\\+", "\\\\+", names(bibtex))
    cited <- sapply(enames, function(name) length(grep(name, tex)) > 0)
    biblist <- bibtex[cited]
    class(biblist) <- "txtBibtex"
    return(biblist)
}

### output to a file
toBibtex.txtBibtex <- function(object, ...) {

    tmp <- lapply(object, function(bib) {
        cat(paste(bib, "\n"))
        cat("\n\n")
    })
}

### set package version in BibTeX (quick'n'dirty hack)
pkgversions <- function(file) {

    x <- readLines(file)
    indx <- grep("VERSION", x)

    for (i in indx) {
        xx <- strsplit(x[i], " ")[[1]]
        xx <- xx[grep("VERSION", xx)]
        pkg <- gsub("[},]", "", gsub("VERSION", "", xx))
        version <- packageDescription(pkg)$Version
        x[i] <- gsub(paste(pkg, "VERSION", sep = "", collapse = ""), version, 
                     x[i])
    }
    class(x) <- "Latex"
    x
}

pkgs <- function()
 c("scatterplot3d", "ape", "coin", "flexmix", "gee", "ipred", "lme4",
   "mclust", "party", "randomForest", "rmeta", "vcd")
