Sweave <- function(file, driver=RweaveLatex(),
                   syntax=getOption("SweaveSyntax"), ...)
{
    if(is.character(driver))
        driver <- get(driver, mode="function")()
    else if(is.function(driver))
        driver <- driver()


    if(is.null(syntax))
        syntax <- SweaveGetSyntax(file)
    if(is.character(syntax))
        syntax <- get(syntax, mode="list")

    drobj <- driver$setup(file=file, syntax=syntax, ...)
    on.exit(driver$finish(drobj, error=TRUE))

    text <- readLines(file)

    mode <- "doc"
    chunknr <- 0
    chunk <- NULL

    namedchunks <- list()
    for(line in text){
        if(any(grep(syntax$doc, line))){
            if(mode=="doc"){
                if(!is.null(chunk))
                    drobj <- driver$writedoc(drobj, chunk)
                mode <- "doc"
            }
            else{
                if(!is.null(chunkopts$label))
                    namedchunks[[chunkopts$label]] <- chunk
                if(!is.null(chunk))
                    drobj <- driver$runcode(drobj, chunk, chunkopts)
                mode <- "doc"
            }
            chunk <- NULL
        }
        else if(any(grep(syntax$code, line))){
            if(mode=="doc"){
                if(!is.null(chunk))
                    drobj <- driver$writedoc(drobj, chunk)
                mode <- "code"
            }
            else{
                if(!is.null(chunkopts$label))
                    namedchunks[[chunkopts$label]] <- chunk
                if(!is.null(chunk))
                    drobj <- driver$runcode(drobj, chunk, chunkopts)
                mode <- "code"
            }
            chunkopts <- sub(syntax$code, "\\1", line)
            chunkopts <- SweaveParseOptions(chunkopts,
                                            drobj$options,
                                            driver$checkopts)
            chunk <- NULL
            chunknr <- chunknr+1
            chunkopts$chunknr <- chunknr
        }
        else{
            if(mode=="code" && any(grep(syntax$coderef, line))){
                chunkref <- sub(syntax$coderef, "\\1", line)
                if(!(chunkref %in% names(namedchunks)))
                    warning(paste("Reference to unknown chunk",
                                  chunkref))
                line <- namedchunks[[chunkref]]
            }
            else if(mode=="doc" && any(grep(syntax$syntaxname, line))){
                sname <- sub(syntax$syntaxname, "\\1", line)
                syntax <- get(sname, mode = "list")
                if(class(syntax) != "SweaveSyntax")
                    stop(paste("Object '", sname,
                               "'has not class SweaveSyntax"))
                drobj$syntax <- syntax
            }
            if(is.null(chunk))
                chunk <- line
            else
                chunk <- c(chunk, line)
        }
    }
    if(!is.null(chunk)){
        if(mode=="doc") driver$writedoc(drobj, chunk)
        else drobj <- driver$runcode(drobj, chunk, chunkopts)
    }

    on.exit()
    driver$finish(drobj)
}

###**********************************************************

SweaveSyntaxNoweb <-
    list(doc = "^@",
         code = "^<<(.*)>>=.*",
         coderef = "^<<(.*)>>.*",
         docopt = "\\\\SweaveOpts\\{([^\\}]*)\\}",
         docexpr = "\\\\Sexpr\\{([^\\}]*)\\}",
         extension = "\\.[rsRS]?nw$",
         syntaxname = "\\\\SweaveSyntax\\{([^\\}]*)\\}",
         trans = list(
             doc = "@",
             code = "<<\\1>>=",
             coderef = "<<\\1>>",
             docopt = "\\\\SweaveOpts{\\1}",
             docexpr = "\\\\Sexpr{\\1}",
             extension = ".Snw",
             syntaxname = "\\\\SweaveSyntax{SweaveSyntaxNoweb}")
         )

class(SweaveSyntaxNoweb) <- "SweaveSyntax"

SweaveSyntaxLatex <- SweaveSyntaxNoweb
SweaveSyntaxLatex$doc <-  "^[[:space:]]*\\\\end\\{Scode\\}"
SweaveSyntaxLatex$code <- "^[[:space:]]*\\\\begin\\{Scode\\}\\{?([^\\}]*)\\}?.*"
SweaveSyntaxLatex$coderef <- "^[[:space:]]*\\\\Scoderef\\{([^\\}]*)\\}.*"
SweaveSyntaxLatex$extension <- "\\.[rsRS]tex$"

SweaveSyntaxLatex$trans$doc <-  "\\\\end{Scode}"
SweaveSyntaxLatex$trans$code <- "\\\\begin{Scode}{\\1}"
SweaveSyntaxLatex$trans$coderef <- "\\\\Scoderef{\\1}"
SweaveSyntaxLatex$trans$syntaxname <- "\\\\SweaveSyntax{SweaveSyntaxLatex}"
SweaveSyntaxLatex$trans$extension <- ".Stex"

###**********************************************************

SweaveGetSyntax <- function(file){

    synt <- apropos("SweaveSyntax", mode="list")
    for(sname in synt){
        s <- get(sname, mode="list")
        if(class(s) != "SweaveSyntax") next
        if(any(grep(s$extension, file))) return(s)
    }
    return(SweaveSyntaxNoweb)
}


SweaveSyntConv <- function(file, syntax, output=NULL)
{
    if(is.character(syntax))
        syntax <- get(syntax)

    if(class(syntax) != "SweaveSyntax")
        stop("Target syntax not of class `SweaveSyntax'.\n")

    if(is.null(syntax$trans))
        stop("Target syntax contains no translation table.\n")

    insynt <- SweaveGetSyntax(file)
    text = readLines(file)
    if(is.null(output))
        output = sub(insynt$extension, syntax$trans$extension, basename(file))

    TN = names(syntax$trans)

    for(n in TN){
        if(n!="extension")
            text = gsub(insynt[[n]], syntax$trans[[n]], text)
    }

    cat(text, file=output, sep="\n")
    cat("Wrote file", output, "\n")
}




###**********************************************************

SweaveParseOptions <- function(text, defaults=list(), check=NULL)
{
    x <- sub("^[[:space:]]*\(.*\)", "\\1", text)
    x <- sub("\(.*[^[:space:]]\)[[:space:]]*$", "\\1", x)
    x <- unlist(strsplit(x, "[[:space:]]*,[[:space:]]*"))
    x <- strsplit(x, "[[:space:]]*=[[:space:]]*")

    ## only the first option may have no name: the chunk label
    if(length(x)>0){
        if(length(x[[1]])==1){
            x[[1]] <- c("label", x[[1]])
        }
    }
    else
        return(defaults)

    if(any(sapply(x, length)!=2))
        stop(paste("Parse error or empty option in\n", text))

    options <- defaults

    for(k in 1:length(x))
        options[[ x[[k]][1] ]] <- x[[k]][2]

    if(!is.null(options[["label"]]) && !is.null(options[["engine"]]))
        options[["label"]] <- sub(paste(".", options[["engine"]], "$",
                                        sep=""),
                                  "", options[["label"]])

    if(!is.null(check))
        options <- check(options)

    options
}

SweaveHooks <- function(options, run=FALSE, envir=.GlobalEnv)
{
    if(is.null(SweaveHooks <- getOption("SweaveHooks")))
        return(NULL)

    z <- character(0)
    for(k in names(SweaveHooks)){
        if(k != "" && !is.null(options[[k]]) && options[[k]]){
            if(is.function(SweaveHooks[[k]])){
                z <- c(z, k)
                if(run)
                    eval(SweaveHooks[[k]](), envir=envir)
            }
        }
    }
    z
}





###**********************************************************


RweaveLatex <- function()
{
    list(setup = RweaveLatexSetup,
         runcode = RweaveLatexRuncode,
         writedoc = RweaveLatexWritedoc,
         finish = RweaveLatexFinish,
         checkopts = RweaveLatexOptions)
}

RweaveLatexSetup <-
    function(file, syntax,
             output=NULL, quiet=FALSE, debug=FALSE, echo=TRUE,
             eval=TRUE, split=FALSE, stylepath=TRUE, pdf=TRUE, eps=TRUE)
{
    if(is.null(output)){
        prefix.string <- basename(sub(syntax$extension, "", file))
        output <- paste(prefix.string, "tex", sep=".")
    }
    else{
        prefix.string <- basename(sub("\\.tex$", "", output))
    }
    if(!quiet) cat("Writing to file ", output, "\n",
                   "Processing code chunks ...\n", sep="")
    output <- file(output, open="w+")

    if(stylepath){
        styfile <- file.path(R.home(),"share","texmf","Sweave")
        if(.Platform$OS.type == "windows")
            styfile <- gsub("\\\\", "/", styfile)
        if(any(grep(" ", styfile)))
            warning(paste("Path '", styfile, "' contains spaces,\n",
                          "this may cause problems when running latex.",
                          sep=""))
    }
    else
        styfile <- "Sweave"

    options <- list(prefix=TRUE, prefix.string=prefix.string,
                    engine="R", print=FALSE, eval=eval,
                    fig=FALSE, pdf=pdf, eps=eps,
                    width=6, height=6, term=TRUE,
                    echo=echo, results="verbatim", split=split,
                    strip.white=TRUE, include=TRUE)

    list(output=output, styfile=styfile, havesty=FALSE,
         debug=debug, quiet=quiet, syntax = syntax,
         options=options, chunkout=list())
}

RweaveLatexRuncode <- function(object, chunk, options)
{
    if(!(options$engine %in% c("R", "S"))){
        return(object)
    }

    if(!object$quiet){
        cat(formatC(options$chunknr, width=2), ":")
        if(options$echo) cat(" echo")
        if(options$eval){
            if(options$print) cat(" print")
            if(options$term) cat(" term")
            cat("", options$results)
            if(options$fig){
                if(options$eps) cat(" eps")
                if(options$pdf) cat(" pdf")
            }
        }
        if(!is.null(options$label))
            cat(" (label=", options$label, ")", sep="")
        cat("\n")
    }

    chunkprefix <- RweaveChunkPrefix(options)

    if(options$split){
        chunkout <- object$chunkout[[chunkprefix]]
        if(is.null(chunkout)){
            chunkout <- file(paste(chunkprefix, "tex", sep="."), "w")
            if(!is.null(options$label))
                object$chunkout[[chunkprefix]] <- chunkout
        }
    }
    else
        chunkout <- object$output

    SweaveHooks(options, run=TRUE)
    
    chunkexps <- try(parse(text=chunk), silent=TRUE)
    RweaveTryStop(chunkexps, options)
    openSinput <- FALSE
    openSchunk <- FALSE
    
    if(length(chunkexps)==0)
        return(object)

    for(nce in 1:length(chunkexps))
    {
        ce <- chunkexps[[nce]]
        dce <- deparse(ce, width.cutoff=0.75*getOption("width"))
        if(object$debug)
            cat("\nRnw> ", paste(dce, collapse="\n+  "),"\n")
        if(options$echo){
            if(!openSinput){
                if(!openSchunk){
                    cat("\\begin{Schunk}\n",
                        file=chunkout, append=TRUE)
                    openSchunk <- TRUE
                }
                cat("\\begin{Sinput}",
                    file=chunkout, append=TRUE)
                openSinput <- TRUE
            }
            cat("\n", getOption("prompt"),
                paste(dce,
                      collapse=paste("\n", getOption("continue"), sep="")),
                file=chunkout, append=TRUE, sep="")
        }

        # tmpcon <- textConnection("output", "w")
        # avoid the limitations (and overhead) of output text connections
        tmpcon <- file()
        sink(file=tmpcon)
        err <- NULL
        if(options$eval) err <- RweaveEvalWithOpt(ce, options)
        cat("\n") # make sure final line is complete
        sink()
        output <- readLines(tmpcon)
        close(tmpcon)
        ## delete empty output
        if(length(output)==1 & output[1]=="") output <- NULL

        RweaveTryStop(err, options)
        
        if(object$debug)
            cat(paste(output, collapse="\n"))

        if(length(output)>0 & (options$results != "hide")){
                                                        
            if(openSinput){
                cat("\n\\end{Sinput}\n", file=chunkout, append=TRUE)
                openSinput <- FALSE
            }
            if(options$results=="verbatim"){
                if(!openSchunk){
                    cat("\\begin{Schunk}\n",
                        file=chunkout, append=TRUE)
                    openSchunk <- TRUE
                }
                cat("\\begin{Soutput}\n",
                    file=chunkout, append=TRUE)
            }

            output <- paste(output,collapse="\n")
            if(options$strip.white){
                output <- sub("^[[:space:]]*\n", "", output)
                output <- sub("\n[[:space:]]*$", "", output)
            }
            cat(output, file=chunkout, append=TRUE)
            remove(output)

            if(options$results=="verbatim"){
                cat("\n\\end{Soutput}\n", file=chunkout, append=TRUE)
            }
        }
    }

    if(openSinput){
        cat("\n\\end{Sinput}\n", file=chunkout, append=TRUE)
    }

    if(openSchunk){
        cat("\\end{Schunk}\n", file=chunkout, append=TRUE)
    }

    if(is.null(options$label) & options$split)
        close(chunkout)

    if(options$split & options$include)
        cat("\\input{", chunkprefix, "}\n", sep="",
            file=object$output, append=TRUE)

    if(options$fig && options$eval){
        if(options$eps){
            postscript(file=paste(chunkprefix, "eps", sep="."),
                       width=options$width, height=options$height,
                       paper="special", horizontal=FALSE)

            err <- try({SweaveHooks(options, run=TRUE);
                        eval(chunkexps, envir=.GlobalEnv)})
            dev.off()
            if(inherits(err, "try-error")) stop(err)
        }
        if(options$pdf){
            pdf(file=paste(chunkprefix, "pdf", sep="."),
                width=options$width, height=options$height)

            err <- try({SweaveHooks(options, run=TRUE);
                        eval(chunkexps, envir=.GlobalEnv)})
            dev.off()
            if(inherits(err, "try-error")) stop(err)
        }
        if(options$include)
            cat("\\includegraphics{", chunkprefix, "}\n", sep="",
                file=object$output, append=TRUE)
    }
    return(object)
}

RweaveLatexWritedoc <- function(object, chunk)
{
    if(any(grep("\\usepackage[^\\}]*Sweave.*\\}", chunk)))
        object$havesty <- TRUE

    if(!object$havesty){
        chunk <- gsub("\\\\begin\\{document\\}",
                      paste("\\\\usepackage{",
                            object$styfile,
                            "}\n\\\\begin{document}", sep=""),
                      chunk)
        object$havesty <- TRUE
    }

    while(any(pos <- grep(object$syntax$docexpr, chunk)))
    {
        cmdloc <- regexpr(object$syntax$docexpr, chunk[pos[1]])
        cmd <- substr(chunk[pos[1]], cmdloc,
                      cmdloc+attr(cmdloc, "match.length")-1)
        cmd <- sub(object$syntax$docexpr, "\\1", cmd)
        if(object$options$eval)
            val <- as.character(eval(parse(text=cmd), envir=.GlobalEnv))
        else
            val <- paste("\\\\verb{<<", cmd, ">>{", sep="")

        chunk[pos[1]] <- sub(object$syntax$docexpr, val, chunk[pos[1]])
    }
    while(any(pos <- grep(object$syntax$docopt, chunk)))
    {
        opts <- sub(paste(".*", object$syntax$docopt, ".*", sep=""),
                    "\\1", chunk[pos[1]])
        object$options <- SweaveParseOptions(opts, object$options,
                                             RweaveLatexOptions)
        chunk[pos[1]] <- sub(object$syntax$docopt, "", chunk[pos[1]])
    }

    cat(chunk, sep="\n", file=object$output, append=TRUE)
    return(object)
}

RweaveLatexFinish <- function(object, error=FALSE)
{
    if(!object$quiet && !error)
        cat(paste("\nYou can now run LaTeX on",
                  summary(object$output)$description), "\n")
    close(object$output)
    if(length(object$chunkout)>0){
        for(con in object$chunkout) close(con)
    }
}

RweaveLatexOptions <- function(options)
{
    ## convert a character string to logical
    c2l <- function(x){
        if(is.null(x)) return(FALSE)
        else return(as.logical(toupper(as.character(x))))
    }

    NUMOPTS <- c("width", "height")
    NOLOGOPTS <- c(NUMOPTS, "results", "prefix.string",
                   "engine", "label")

    for(opt in names(options)){
        if(! (opt %in% NOLOGOPTS)){
            oldval <- options[[opt]]
            if(!is.logical(options[[opt]])){
                options[[opt]] <- c2l(options[[opt]])
            }
            if(is.na(options[[opt]]))
                stop(paste("invalid value for", opt, ":", oldval))
        }
        else if(opt %in% NUMOPTS){
            options[[opt]] <- as.numeric(options[[opt]])
        }
    }

    options$results <- match.arg(options$results,
                                 c("verbatim", "tex", "hide"))

    options
}


RweaveChunkPrefix <- function(options)
{
    if(!is.null(options$label)){
        if(options$prefix)
            chunkprefix <- paste(options$prefix.string, "-",
                                 options$label, sep="")
        else
            chunkprefix <- options$label
    }
    else
        chunkprefix <- paste(options$prefix.string, "-",
                             formatC(options$chunknr, flag="0", width=3),
                             sep="")

    return(chunkprefix)
}

RweaveEvalWithOpt <- function (expr, options){
    if(options$eval){
        res <- try(.Internal(eval.with.vis(expr, .GlobalEnv, NULL)),
                   silent=TRUE)
        if(inherits(res, "try-error")) return(res)
        if(options$print | (options$term & res$visible))
            print(res$value)
    }
    return(res)
}


RweaveTryStop <- function(err, options){

    if(inherits(err, "try-error")){
        cat("\n")
        msg <- paste(" chunk", options$chunknr)
        if(!is.null(options$label))
            msg <- paste(msg, " (label=", options$label, ")", sep="")
        msg <- paste(msg, "\n")
        stop(msg, err, call.=FALSE)
    }
}
           
        



###**********************************************************

Stangle <- function(file, driver=Rtangle(),
                    syntax=getOption("SweaveSyntax"), ...)
{
    Sweave(file=file, driver=driver, ...)
}

Rtangle <-  function()
{
    list(setup = RtangleSetup,
         runcode = RtangleRuncode,
         writedoc = RtangleWritedoc,
         finish = RtangleFinish,
         checkopts = RweaveLatexOptions)
}


RtangleSetup <- function(file, syntax,
                         output=NULL, annotate=TRUE, split=FALSE,
                         prefix=TRUE, quiet=FALSE)
{
    if(is.null(output)){
        prefix.string <- basename(sub(syntax$extension, "", file))
        output <- paste(prefix.string, "R", sep=".")
    }
    else{
        prefix.string <- basename(sub("\\.[rsRS]$", "", output))
    }

    if(!split){
        if(!quiet)
            cat("Writing to file", output, "\n")
        output <- file(output, open="w")
    }
    else{
        if(!quiet)
            cat("Writing chunks to files ...\n")
        output <- NULL
    }

    options <- list(split=split, prefix=prefix,
                    prefix.string=prefix.string,
                    engine="R")

    list(output=output, annotate=annotate, options=options,
         chunkout=list(), quiet=quiet, syntax=syntax)
}


RtangleRuncode <-  function(object, chunk, options)
{
    if(!(options$engine %in% c("R", "S"))){
        return(object)
    }

    chunkprefix <- RweaveChunkPrefix(options)

    if(options$split){
        outfile <- paste(chunkprefix, options$engine, sep=".")
        if(!object$quiet)
            cat(options$chunknr, ":", outfile,"\n")
        chunkout <- object$chunkout[[chunkprefix]]
        if(is.null(chunkout)){
            chunkout <- file(outfile, "w")
            if(!is.null(options$label))
                object$chunkout[[chunkprefix]] <- chunkout
        }
    }
    else
        chunkout <- object$output

    if(object$annotate){
        cat("###################################################\n",
            "### chunk number ", options$chunknr,
            ": ", options$label, "\n",
            "###################################################\n",
            file=chunkout, append=TRUE, sep="")
    }

    hooks <- SweaveHooks(options, run=FALSE)
    for(k in hooks)
        cat("getOption(\"SweaveHooks\")[[\"", k, "\"]]()\n",
            file=chunkout, append=TRUE, sep="")

    cat(chunk,"\n", file=chunkout, append=TRUE, sep="\n")

    if(is.null(options$label) & options$split)
        close(chunkout)

    return(object)
}

RtangleWritedoc <- function(object, chunk)
{
    while(any(pos <- grep(object$syntax$docopt, chunk)))
    {
        opts <- sub(paste(".*", object$syntax$docopt, ".*", sep=""),
                    "\\1", chunk[pos[1]])
        object$options <- SweaveParseOptions(opts, object$options)
        chunk[pos[1]] <- sub(object$syntax$docopt, "", chunk[pos[1]])
    }
    return(object)
}


RtangleFinish <- function(object, error=FALSE)
{
    if(!is.null(object$output))
        close(object$output)

    if(length(object$chunkout)>0){
        for(con in object$chunkout) close(con)
    }
}

apropos <- function (what, where = FALSE, mode = "any")
{
    if(!is.character(what))
	what <- as.character(substitute(what))
    x <- character(0)
    check.mode <- mode != "any"
    for (i in seq(search())) {
	ll <- length(li <- ls(pos = i, pattern = what, all.names = TRUE))
	if (ll) {
	    if(check.mode)
		ll <- length(li <- li[sapply(li, function(x)
					     exists(x, where = i,
						    mode = mode, inherits=FALSE))])
	    x <- c(x, if (where) structure(li, names = rep.int(i, ll)) else li)
	}
    }
    x
}

find <- function(what, mode = "any", numeric. = FALSE, simple.words=TRUE) {
    if(!is.character(what))
	what <- as.character(substitute(what))
    if(length(what) > 1) {
        warning("elements of 'what' after the first will be ignored")
        what <- what[1]
    }
#   would need to escape at least + * | as well
#     if(simple.words)
# 	what <- gsub("([.[])", "\\\\\\1", paste("^",what,"$", sep=""))
    len.s <- length(sp <- search())
    ind <- logical(len.s)
    if((check.mode <- mode != "any"))
	nam <- character(len.s)
    for (i in 1:len.s) {
        if(simple.words) {
            li <- ls(pos = i, all.names = TRUE)
            found <- what %in% ls(pos = i, all.names = TRUE)
            if(found && check.mode)
                found <- exists(what, where = i, mode = mode, inherits=FALSE)
            ind[i] <- found
        } else {
            li <- ls(pos = i, pattern = what, all.names = TRUE)
            ll <- length(li)
            if(ll > 0 && check.mode) {
                mode.ok <- sapply(li, exists, where = i, mode = mode,
                                  inherits = FALSE)
                ll <- sum(mode.ok)
                if(ll >= 2) warning(paste(ll, "occurrences in", sp[i]))
            }
            ind[i] <- ll > 0
        }
    }
    ## found name in  search()[ ind ]
    if(numeric.) structure(which(ind), names=sp[ind]) else sp[ind]
}

"capture.output" <-
  function(...,file=NULL,append=FALSE){

    args<-substitute(list(...))[-1]

    if (is.null(file)){
      file<-textConnection("rval",ifelse(append,"a","w"), local=TRUE)
      sink(file)
      on.exit({sink();close(file)})
    }else if (inherits(file,"connection")){
	rval<-invisible(NULL)
	if (!isOpen(file)){
	  open(file,ifelse(append,"a","w"))
	  sink(file)
	  on.exit({sink();close(file)})  
	} else{
	   sink(file) 
	   on.exit(sink())
	}
    } else {
      file <- file(file, ifelse(append,"a","w"))
      rval <- invisible(NULL)
      sink(file)
      on.exit({sink();close(file)})
    } 
    
    pf<-parent.frame()
    evalVis<-function(expr)
      .Internal(eval.with.vis(expr, pf, NULL))

    for(i in seq(length=length(args))){
      expr<-args[[i]]
      if(mode(expr)=="expression")
        tmp<-lapply(expr, evalVis)
      else if (mode(expr)=="call")
        tmp<-list(evalVis(expr))
      else if (mode(expr)=="name")
          tmp<-list(evalVis(expr))
      else stop("Bad argument")
    
      for(item in tmp){
        if (item$visible)
          print(item$value)
      }
    }
    rval
  }
browseEnv <- function(envir = .GlobalEnv, pattern,
                      excludepatt = "^last\\.warning",
		      html = .Platform$OS.type != "mac",
		      expanded = TRUE, properties = NULL,
		      main = NULL, debugMe = FALSE)
{
    objlist <- ls(envir = envir, pattern = pattern)#, all.names = FALSE
    if(length(iX <- grep(excludepatt, objlist)))
        objlist <- objlist[ - iX]
    if(debugMe) { cat("envir= "); print(envir)
		  cat("objlist =\n"); print(objlist) }
    n <- length(objlist)
    if(n == 0) {
	cat("Empty environment, nothing to do!\n")
	return(invisible())
    }

    str1 <- function(obj) {
	md <- mode(obj)
	lg <- length(obj)
	objdim <- dim(obj)
	if(length(objdim) == 0)
	    dim.field <- paste("length:", lg)
	else{
	    dim.field <- "dim:"
	    for(i in 1:length(objdim))
		dim.field <- paste(dim.field,objdim[i])
	    if(is.matrix(obj))
		md <- "matrix"
	}
	obj.class <- oldClass(obj)
	if(!is.null(obj.class)) {
	    md <- obj.class[1]
	    if(inherits(obj, "factor"))
		dim.field <- paste("levels:",length(levels(obj)))
	}
	list(type = md, dim.field = dim.field)
    }

    N <- 0
    M <- n
    IDS <- rep.int(NA,n)
    NAMES <- rep.int(NA,n)
    TYPES <- rep.int(NA,n)
    DIMS <- rep.int(NA,n)

    IsRoot <- rep.int(TRUE,n)
    Container <- rep.int(FALSE,n)
    ItemsPerContainer <- rep.int(0,n)
    ParentID <- rep.int(-1,n)

    for( objNam in objlist ){
	N <- N+1
	if(debugMe) cat("  ", N,":", objNam)
	obj    <- get(objNam, envir = envir)

	sOb <- str1(obj)

	if(debugMe) cat(", type=", sOb$type,",", sOb$dim.field,"\n")

	## Fixme : put these 4 in a matrix or data.frame row:
	IDS[N] <- N
	NAMES[N] <- objNam
	TYPES[N] <- sOb$type
	DIMS[N] <- sOb$dim.field

	if(is.recursive(obj) && !is.function(obj) && !is.environment(obj)
	    ## includes "list", "expression", also "data.frame", ..
	   && (lg <- length(obj)) > 0) {
	    Container[N] <- TRUE
	    ItemsPerContainer[N] <- lg
	    nm <- names(obj)
	    if(is.null(nm)) nm <- paste("[[",format(1:lg),"]]", sep="")
	    for(i in 1:lg) {
		M <- M+1
		ParentID[M] <- N
		if(nm[i] == "") nm[i] <- paste("[[",i,"]]", sep="")

		s.l <- str1(obj[[i]])
		##cat("	   objname:",nm[i],", type=",md.l,",",dim.field.l,"\n")
		IDS   <- c(IDS,M)
		NAMES <- c(NAMES, nm[i])
		TYPES <- c(TYPES, s.l$type)
		DIMS  <- c(DIMS,  s.l$dim.field)
	    }
	}## recursive

	else if(!is.null(class(obj))) {
	    ## treat some special __non-recursive__ classes:
	    if(inherits(obj, "table")) {
		obj.nms <- attr(obj,"dimnames")
		lg <- length(obj.nms)
		if(length(names(obj.nms)) >0)
		    nm <- names(obj.nms)
		else
		    nm <- rep.int("",lg)
		Container[N] <- TRUE
		ItemsPerContainer[N] <- lg
		for(i in 1:lg){
		    M <- M+1
		    ParentID[M] <- N
		    if(nm[i] == "") nm[i] = paste("[[",i,"]]",sep="")
		    md.l  <- mode(obj.nms[[i]])
		    objdim.l <- dim(obj.nms[[i]])
		    if(length(objdim.l) == 0)
			dim.field.l <- paste("length:",length(obj.nms[[i]]))
		    else{
			dim.field.l <- "dim:"
			for(j in 1:length(objdim.l))
			    dim.field.l <- paste(dim.field.l,objdim.l[i])
		    }
		    ##cat("    objname:",nm[i],", type=",md.l,",",dim.field.l,"\n")
		    IDS <- c(IDS,M)
		    NAMES <- c(NAMES, nm[i])
		    TYPES <- c(TYPES, md.l)
		    DIMS <- c(DIMS,dim.field.l)
		}
	    }## "table"

	    else if(inherits(obj, "mts")) {

		nm <- dimnames(obj)[[2]]
		lg <- length(nm)
		Container[N] <- TRUE
		ItemsPerContainer[N] <- lg
		for(i in 1:lg){
		    M <- M+1
		    ParentID[M] <- N
		    md.l  <- mode(obj[[i]])
		    dim.field.l <- paste("length:",dim(obj)[1])
		    md.l <- "ts"
		    ##cat("    tseries:",nm[i],", type=",md.l,",",dim.field.l,"\n")
		    IDS <- c(IDS,M)
		    NAMES <- c(NAMES, nm[i])
		    TYPES <- c(TYPES, md.l)
		    DIMS <- c(DIMS,dim.field.l)
		}
	    }## "mts"

	} ## recursive or classed

    } ## "for each object"

    if(debugMe) cat(" __end {for}\n ")##; browser()

    Container	      <- c(Container,	  rep.int(FALSE, M-N))
    IsRoot	      <- c(IsRoot,	  rep.int(FALSE, M-N))
    ItemsPerContainer <- c(ItemsPerContainer, rep.int(0, M-N))

    if(is.null(main))
	main <- paste("R objects in", deparse(substitute(envir)))
    if(is.null(properties)) {
	properties <- as.list(c(date = format(Sys.time(), "%Y-%b-%d %H:%M"),
				local({
				    si <- Sys.info()
				    si[c("user","nodename","sysname")]})))
    }
    if(html)
	wsbrowser(IDS,IsRoot,Container,ItemsPerContainer, ParentID,
		  NAMES,TYPES,DIMS,
		  kind = "HTML", main = main, properties = properties,
		  expanded)
    else ## currently only for Mac:
	.Internal(wsbrowser(as.integer(IDS),IsRoot,Container,
			    as.integer(ItemsPerContainer),as.integer(ParentID),
			    NAMES,TYPES,DIMS))
}

wsbrowser <- function(IDS, IsRoot, IsContainer, ItemsPerContainer,
		      ParentID, NAMES, TYPES, DIMS, expanded=TRUE,
		      kind = "HTML",
		      main = "R Workspace", properties = list(),
		      browser = getOption("browser"))
{
    if(kind != "HTML") stop("kind `",kind,"'  not yet implemented")

    Pst <- function(...) paste(..., sep="")

    bold <- function(ch) Pst("<b>",ch,"</b>")
    ital <- function(ch) Pst("<i>",ch,"</i>")
    entry<- function(ch) Pst("<td>",ch,"</td>")
    Par	 <- function(ch) Pst("<P>",ch,"</P>")
    Trow <- function(N, ...) {
	if(length(list(...)) != N) stop("wrong number of table row entries")
	paste("<tr>", ..., "</tr>\n")
    }
    catRow <- function(...) cat(Trow(nCol, ...), file = Hfile)

#    n <- length(IDS)
    RootItems <- which(IsRoot)
    NumOfRoots <- length(RootItems)

    props <- properties
    if(length(props)) { ## translate named list into 2-column (vertical) table
	nms <- names(props)
	nms <- unlist(lapply(unlist(lapply(Pst(nms,":"),
					   bold)),
			     entry))
	props <- unlist(lapply(props, entry))
	props <-
	    paste("<table border=2>",
		  paste(Trow(1, paste(nms, props)), collapse=""),
		  "</table>", sep = "\n")
    }
    fname <- file.path(tempdir(), "wsbrowser.html")
    Hfile <- file(fname,"w")

    cat("<html>\n<title>", main, "browser</title>\n<body>",
	"<H1>",main,"</H1>\n",
	if(is.character(props)) Par(props),
	"<table border=1>\n", file = Hfile)
    nCol <- if(expanded) 4 else 3
    catRow(entry(bold("Object")),
	   if(expanded) entry(bold(ital("(components)"))),
	   entry(bold("Type")),
	   entry(bold("Property")))

    for(i in 1:NumOfRoots) {
	iid <- RootItems[i]
	catRow(entry(NAMES[iid]),
	       if(expanded) entry(""),
	       entry(ital(TYPES[iid])),
	       entry(DIMS[iid]))
	if(IsContainer[i] && expanded) {
	    items <- which(ParentID == i)
	    for(j in 1:ItemsPerContainer[i]) {
		id <- IDS[items[j]]
		catRow(entry(""),
		       entry(NAMES[id]),#was Pst("$",NAMES[id]) : ugly for [[i]]
		       entry(ital(TYPES[id])),
		       entry(DIMS[id]))
	    }
	}
    }
    cat("</table>\n</body></html>",file=Hfile)
    close(Hfile)

    switch(.Platform$OS.type,
	   windows = , ## do we need anything here?
	   unix = { url <- fname },
	   )
    if(substr(url, 1,1) != "/")
	url <- paste("/", url, sep = "")
    url <- paste("file://", url, sep = "")

    browseURL(url = url, browser = browser)
    cat(main, "environment is shown in browser",
        if(!is.null(browser))paste("`",browser, "'", sep=""),"\n")

    invisible(filename = fname)
}
de.ncols <- function(inlist)
{
    ncols <- matrix(0, nrow=length(inlist), ncol=2)
    i <- 1
    for( telt in inlist ) {
	if( is.matrix(telt) ) {
	    ncols[i, 1] <- ncol(telt)
	    ncols[i, 2] <- 2
	}
	else if( is.list(telt) ) {
	    for( telt2 in telt )
		if( !is.vector(telt2) ) stop("wrong argument to dataentry")
	    ncols[i, 1] <- length(telt)
	    ncols[i, 2] <- 3
	}
	else if( is.vector(telt) ) {
	    ncols[i, 1] <- 1
	    ncols[i, 2] <- 1
	}
	else stop("wrong argument to dataentry")
	i <- i+1
    }
    return(ncols)
}

de.setup <- function(ilist, list.names, incols)
{
    ilen <- sum(incols)
    ivec <- vector("list", ilen)
    inames <- vector("list", ilen)
    i <- 1
    k <- 0
    for( telt in ilist ) {
	k <- k+1
	if( is.list(telt) ) {
	    y <- names(telt)
	    for( j in 1:length(telt) ) {
		ivec[[i]] <- telt[[j]]
		if( is.null(y) || y[j]=="" )
		    inames[[i]] <- paste("var", i, sep="")
		else inames[[i]] <- y[j]
		i <- i+1
	    }
	}
	else if( is.vector(telt) ) {
	    ivec[[i]] <- telt
	    inames[[i]] <- list.names[[k]]
	    i <- i+1
	}
	else if( is.matrix(telt) ) {
	    y <- dimnames(telt)[[2]]
	    for( j in 1:ncol(telt) ) {
		ivec[[i]] <- telt[, j]
		if( is.null(y) || y[j]=="" )
		    inames[[i]] <- paste("var", i, sep="")
		else inames[[i]] <- y[j]
		i <- i+1
	    }
	}
	else stop("de.setup: wrong argument to dataentry")
    }
    names(ivec) <- inames
    return(ivec)
}

de.restore <- function(inlist, ncols, coltypes, argnames, args)
{
    ## take the data in inlist and restore it
    ## to the format described by ncols and coltypes
    p <- length(ncols)
    rlist <- vector("list", length=p)
    rnames <- vector("character", length=p)
    j <- 1
    lnames <- names(inlist)
    if(p) for(i in 1:p) {
	if(coltypes[i]==2) {
	    tlen <- length(inlist[[j]])
	    x <- matrix(0, nrow=tlen, ncol=ncols[i])
	    cnames <- vector("character", ncol(x))
	    for( ind1 in 1:ncols[i]) {
		if(tlen != length(inlist[[j]]) ) {
		    warning("could not restore type information")
		    return(inlist)
		}
		x[, ind1] <- inlist[[j]]
		cnames[ind1] <- lnames[j]
		j <- j+1
	    }
	    if( dim(x) == dim(args[[i]]) )
		rn <- dimnames(args[[i]])[[1]]
	    else rn <- NULL
	    if( any(cnames!="") )
		dimnames(x) <- list(rn, cnames)
	    rlist[[i]] <- x
	    rnames[i] <- argnames[i]
	}
	else if(coltypes[i]==3) {
	    x <- vector("list", length=ncols[i])
	    cnames <- vector("character", ncols[i])
	    for( ind1 in 1:ncols[i]) {
		x[[ind1]] <- inlist[[j]]
		cnames[ind1] <- lnames[j]
		j <- j+1
	    }
	    if( any(cnames!="") )
		names(x) <- cnames
	    rlist[[i]] <- x
	    rnames[i] <- argnames[i]
	}
	else {
	    rlist[[i]] <- inlist[[j]]
	    j <- j+1
	    rnames[i] <- argnames[i]
	}
    }
    names(rlist) <- rnames
    return(rlist)
}

de <- function(..., Modes=list(), Names=NULL)
{
    sdata <- list(...)
    snames <- as.character(substitute(list(...))[-1])
    if( is.null(sdata) ) {
	if( is.null(Names) ) {
	    odata <- vector("list", length=max(1,length(Modes)))
	}
	else {
	    if( (length(Names) != length(Modes)) && length(Modes) ) {
		warning("modes argument ignored")
		Modes <- list()
	    }
	    odata <- vector("list", length=length(Names))
	    names(odata) <- Names
	}
	ncols <- rep.int(1, length(odata))
	coltypes <- rep.int(1, length(odata))
    }
    else {
	ncols <- de.ncols(sdata)
	coltypes <- ncols[, 2]
	ncols <- ncols[, 1]
	odata <- de.setup(sdata, snames, ncols)
	if(length(Names))
	    if( length(Names) != length(odata) )
		warning("names argument ignored")
	    else names(odata) <- Names
	if(length(Modes))
	    if(length(Modes) != length(odata)) {
		warning("modes argument ignored")
		Modes <- list()
	    }
    }
    rdata <- dataentry(odata, as.list(Modes))

    if(any(coltypes != 1)) {
	if(length(rdata) == sum(ncols))
	    rdata <- de.restore(rdata, ncols, coltypes, snames, sdata)
	else warning("could not restore variables properly")
    }
    return(rdata)
}

data.entry <- function(..., Modes=NULL, Names=NULL)
{
    tmp1 <- de(..., Modes=Modes, Names=Names)
    j <- 1
    nn <- names(tmp1)
    for(i in nn) {
	assign(i, tmp1[[j]], env=.GlobalEnv)
	j <- j+1
    }
    if(j==1) warning("not assigned anything!")
    invisible(nn)
}
dump.frames <- function(dumpto = "last.dump", to.file = FALSE)
{
    calls <- sys.calls()
    last.dump <- sys.frames()
    names(last.dump) <- limitedLabels(calls)
    last.dump <- last.dump[-length(last.dump)] # remove this function
    attr(last.dump, "error.message") <- geterrmessage()
    class(last.dump) <- "dump.frames"
    if(dumpto != "last.dump") assign(dumpto, last.dump)
    if (to.file) save(list=dumpto, file = paste(dumpto, "rda", sep="."))
    else assign(dumpto, last.dump, envir=.GlobalEnv)
    invisible()
}

debugger <- function(dump = last.dump)
{
    debugger.look <- function(.selection)
    {
        for(.obj in ls(envir=dump[[.selection]], all.names=TRUE))
            assign(.obj, get(.obj, envir=dump[[.selection]]))
        cat("Browsing in the environment with call:\n   ",
            calls[.selection], "\n", sep="")
        rm(.obj, .selection)
        browser()
    }
    if (class(dump) != "dump.frames") {
        cat("`dump' is not an object of class `dump.frames'\n")
        return(invisible())
    }
    err.action <- getOption("error")
    on.exit(options(error=err.action))
    if (length(msg <- attr(dump, "error.message")))
        cat("Message: ", msg)
    n <- length(dump)
    calls <- names(dump)
    repeat {
        cat("Available environments had calls:\n")
        cat(paste(1:n, ": ", calls,  sep=""), sep="\n")
        cat("\nEnter an environment number, or 0 to exit  ")
        repeat {
            ind <- .Internal(menu(as.character(calls)))
            if(ind <= n) break
        }
        if(ind == 0) return(invisible())
        debugger.look(ind)
    }
}

limitedLabels <- function(value, maxwidth = options()$width)
{
    value <- as.character(value)
    if(is.null(maxwidth) || maxwidth < 40)
        maxwidth <- 40
    if(any(nchar(value) > maxwidth)) {
        trim <- nchar(value) > maxwidth
        value[trim] <- substr(value[trim], 1, maxwidth)
    }
    value
}

recover <-
  function()
{
    if(.isMethodsDispatchOn()) {
        ## turn off tracing
        tState <- tracingState(FALSE)
        on.exit(tracingState(tState))
    }
    ## find an interesting environment to dump from
    calls <- sys.calls()
    from <- 0
    n <- length(calls)
    if(identical(sys.function(n), recover))
        ## options(error=recover) produces a call to this function as an object
        n <- n - 1
    for(i in rev(seq(length=n))) {
        calli <- calls[[i]]
        fname <- calli[[1]]
        if(!is.name(fname) ||
           is.na(match(as.character(fname), c("recover", "stop", "Stop")))) {
            from <- i
            break
        }
    }
    if(from > 0) {
        if(!interactive()) {
            try(dump.frames())
            message("recover called non-interactively; frames dumped, use debugger() to view")
            return(NULL)
        }
        else if(identical(options()$show.error.messages, FALSE)) { # from try(silent=TRUE)?
            return(NULL)
        }
        calls <- limitedLabels(calls[1:from])
        repeat {
            which <- menu(calls, title="\nEnter a frame number, or 0 to exit  ")
            if(which > 0)
                eval(quote(browser()), envir = sys.frame(which))
            else
                break
        }
    }
    else
        cat("No suitable frames for recover()\n")
}
demo <-
function(topic, device = getOption("device"),
	 package = .packages(), lib.loc = NULL,
	 character.only = FALSE, verbose = getOption("verbose"))
{
    paths <- .find.package(package, lib.loc, verbose = verbose)

    ## Find the directories with a 'demo' subdirectory.
    paths <- paths[tools::fileTest("-d", file.path(paths, "demo"))]
    ## Earlier versions remembered given packages with no 'demo'
    ## subdirectory, and warned about them.

    if(missing(topic)) {
	## List all possible demos.

	## Build the demo db.
	db <- matrix(character(0), nr = 0, nc = 4)
	noindex <- character(0)
	for(path in paths) {
	    entries <- NULL
	    ## Check for new-style 'Meta/demo.rds', then for '00Index'.
	    if(tools::fileTest("-f",
			       INDEX <-
			       file.path(path, "Meta", "demo.rds"))) {
		entries <- .readRDS(INDEX)
	    }
	    else if(tools::fileTest("-f",
				    INDEX <-
				    file.path(path, "demo", "00Index")))
		entries <- read.00Index(INDEX)
	    else {
		## No index: check whether subdir 'demo' contains demos.
		demoDir <- file.path(path, "demo")
		entries <- tools::listFilesWithType(demoDir, "demo")
		if(length(entries) > 0) {
		    entries <-
			unique(tools::filePathSansExt(basename(entries)))
		    entries <- cbind(entries, "")
		}
		else
		    noindex <- c(noindex, basename(path))
	    }
	    if(NROW(entries) > 0) {
		db <- rbind(db,
			    cbind(basename(path), dirname(path),
				  entries))
	    }
	}
	colnames(db) <- c("Package", "LibPath", "Item", "Title")

	if(length(noindex) > 0) {
	    if(!missing(package) && (length(package) > 0)) {
		## Warn about given packages which do not have a demo
		## index.
		packagesWithNoIndex <- package[package %in% noindex]
		if(length(packagesWithNoIndex) > 0)
		    warning(paste("packages with demos",
				  "but no index:",
				  paste(sQuote(packagesWithNoIndex),
					collapse = ",")))
	    }
	}

	footer <- if(missing(package))
	    paste("Use ",
		  sQuote(paste("demo(package =",
			       ".packages(all.available = TRUE))")),
		  "\n",
		  "to list the demos in all *available* packages.",
		  sep = "")
	else
	    NULL
	y <- list(title = "Demos", header = NULL, results = db,
		  footer = footer)
	class(y) <- "packageIQR"
	return(y)
    }

    if(!character.only)
	topic <- as.character(substitute(topic))
    available <- character(0)
    paths <- file.path(paths, "demo")
    for(p in paths) {
	files <- basename(tools::listFilesWithType(p, "demo"))
	## Files with base names sans extension matching topic
	files <- files[topic == tools::filePathSansExt(files)]
	if(length(files) > 0)
	    available <- c(available, file.path(p, files))
    }
    if(length(available) == 0)
	stop(paste("No demo found for topic", sQuote(topic)))
    if(length(available) > 1) {
	available <- available[1]
	warning(paste("Demo for topic ",
		      sQuote(topic),
		      " found more than once,\n",
		      "using the one found in ",
		      sQuote(dirname(available[1])),
		      sep = ""))
    }
    cat("\n\n",
	"\tdemo(", topic, ")\n",
	"\t---- ", rep.int("~", nchar(topic)), "\n",
	sep="")
    if(interactive()) {
	cat("\nType  <Return>	 to start : ")
	readline()
    }
    source(available, echo = TRUE, max.deparse.length = 250)
}
dataentry <- function (data, modes) {
    if(!is.list(data) || !length(data) || !all(sapply(data, is.vector)))
        stop("invalid data argument")
    if(!is.list(modes) ||
       (length(modes) && !all(sapply(modes, is.character))))
        stop("invalid modes argument")
    .Internal(dataentry(data, modes))
}

edit <- function(name,...)UseMethod("edit")

edit.default <-
    function (name = NULL, file = "", editor = getOption("editor"), ...)
{
    if(is.matrix(name) &&
       (mode(name) == "numeric" || mode(name) == "character"))
        edit.matrix(name=name, ...)
    else .Internal(edit(name, file, editor))
}

edit.data.frame <-
    function(name, factor.mode = c("character", "numeric"),
             edit.row.names =  any(row.names(name) != 1:nrow(name)), ...)
{
    if (.Platform$OS.type == "unix"  && .Platform$GUI != "AQUA")
        if(.Platform$GUI == "unknown" || Sys.getenv("DISPLAY")=="" )
            return (edit.default(name, ...))

    is.vector.unclass <- function(x) is.vector(unclass(x))
    if (length(name) > 0 && !all(sapply(name, is.vector.unclass)
                                 | sapply(name, is.factor)))
        stop("Can only handle vector and factor elements")

    factor.mode <- match.arg(factor.mode)

    as.num.or.char <- function(x)
    {
        ## Would as.character be a better default?  BDR 2000/5/3
        if (is.character(x)) x
        else if (is.logical(x) || (is.factor(x) && factor.mode == "character")) as.character(x)
        else as.numeric(x)
    }

    attrlist <- lapply(name, attributes)
    datalist <- lapply(name, as.num.or.char)
    factors <- if (length(name) > 0)
        which(sapply(name, is.factor))
    else
        numeric(0)

    logicals <- if (length(name) > 0)
    	which(sapply(name, is.logical))
    else
    	numeric(0)

    modes <- lapply(datalist, mode)
    if (edit.row.names) {
        datalist <- c(list(row.names=row.names(name)), datalist)
        modes <- c(list(row.names="character"), modes)
    }
    out <- .Internal(dataentry(datalist, modes))
    lengths <- sapply(out, length)
    maxlength <- max(lengths)
    if (edit.row.names) rn <- out[[1]]
    for (i in which(lengths != maxlength))
         out[[i]] <- c(out[[i]], rep.int(NA, maxlength - lengths[i]))
    if (edit.row.names) {
        out <- out[-1]
        if((ln <- length(rn)) < maxlength)
            rn <- c(rn, paste("row", (ln+1):maxlength, sep=""))
    }
    for (i in factors) {
        if(mode(out[[i]]) == "numeric") next # user might have switched mode
        a <- attrlist[[i]]
        if (factor.mode == "numeric") {
            o <- as.integer(out[[i]])
            ok <- is.na(o) | (o > 0 & o <= length(a$levels))
            if (any(!ok)) {
                warning(paste("invalid factor levels in", names(out)[i]))
                o[!ok] <- NA
            }
	    attributes(o) <- a
        } else {
            o <- out[[i]]
            if (any(new <- is.na(match(o, c(a$levels, NA))))) {
                new <- unique(o[new])
                warning(paste("added factor levels in", names(out)[i]))
                o <- factor(o, levels=c(a$levels, new), ordered=is.ordered(o))
            } else {
                o <- match(o, a$levels)
                attributes(o) <- a
            }
        }
        out[[i]] <- o
    }
    for (i in logicals) out[[i]] <- as.logical(out[[i]])

    out <- as.data.frame(out) # will convert cols switched to char into factors
    if (edit.row.names) {
        if(any(duplicated(rn)))
            warning("edited row names contain duplicates and will be ignored")
        else row.names(out) <- rn
    }
    out
}

edit.matrix <-
    function(name, edit.row.names = any(rownames(name) != 1:nrow(name)), ...)
{
    if (.Platform$OS.type == "unix" && .Platform$GUI != "AQUA")
        if(.Platform$GUI == "unknown" || Sys.getenv("DISPLAY")=="" )
            return (edit.default(name, ...))
    if(!is.matrix(name) ||
       !(mode(name) == "numeric" || mode(name) == "character" || mode(name) == "logical")
       || any(dim(name) < 1))
        stop("invalid input matrix")
    logicals <- is.logical(name)
    if (logicals) mode(name) <- "character"
    dn <- dimnames(name)
    if(is.null(dn[[1]])) edit.row.names <- FALSE
    datalist <- split(name, col(name))
    if(!is.null(dn[[2]])) names(datalist) <- dn[[2]]
    else names(datalist) <- paste("col", 1:ncol(name), sep = "")
    modes <- as.list(rep.int(mode(name), ncol(name)))
    if (edit.row.names) {
        datalist <- c(list(row.names=dn[[1]]), datalist)
        modes <- c(list(row.names="character"), modes)
    }
    out <- .Internal(dataentry(datalist, modes))
    lengths <- sapply(out, length)
    maxlength <- max(lengths)
    if (edit.row.names) rn <- out[[1]]
    for (i in which(lengths != maxlength))
         out[[i]] <- c(out[[i]], rep.int(NA, maxlength - lengths[i]))
    if (edit.row.names) {
        out <- out[-1]
        if((ln <- length(rn)) < maxlength)
            rn <- c(rn, paste("row", (ln+1):maxlength, sep=""))
    }
    out <- do.call("cbind", out)
    if (edit.row.names) rownames(out) <- rn
    else if(!is.null(dn[[1]]))  rownames(out) <- dn[[1]]
    if(!is.null(dn[[2]]))  colnames(out) <- dn[[2]]
    if (logicals) mode(out) <- "logical"
    out
}

vi <- function(name=NULL, file="")
    edit.default(name, file, editor="vi")

emacs <- function(name=NULL, file="")
    edit.default(name, file, editor="emacs")

xemacs <- function(name=NULL, file="")
    edit.default(name, file, editor="xemacs")

xedit <- function(name=NULL, file="")
    edit.default(name, file, editor="xedit")

pico <- function(name=NULL, file="")
    edit.default(name, file, editor="pico")


example <-
function(topic, package = .packages(), lib.loc = NULL, local = FALSE,
	 echo = TRUE, verbose = getOption("verbose"), setRNG = FALSE,
	 prompt.echo = paste(abbreviate(topic, 6), "> ", sep = ""))
{
    topic <- substitute(topic)
    if(!is.character(topic))
	topic <- deparse(topic)[1]
    INDICES <- .find.package(package, lib.loc, verbose = verbose)
    file <- index.search(topic, INDICES, "AnIndex", "R-ex")
    if(file == "") {
	warning(paste("No help file found for", sQuote(topic)))
	return(invisible())
    }
    packagePath <- dirname(dirname(file))
    if(length(file) > 1) {
	packagePath <- packagePath[1]
	warning(paste("More than one help file found: using package",
		      sQuote(basename(packagePath))))
	file <- file[1]
    }
    pkg <- basename(packagePath)
    lib <- dirname(packagePath)
    ## experimental code
    zfile <- zip.file.extract(file, "Rex.zip")
    if(zfile != file) on.exit(unlink(zfile))
    ## end of experimental code
    if(!file.exists(zfile)) {
	warning(paste(sQuote(topic),
		      "has a help file but no examples file"))
	return(invisible())
    }
    if(pkg != "base")
	library(pkg, lib = lib, character.only = TRUE)
    if(!is.logical(setRNG) || setRNG) {
	## save current RNG state:
	if((has.seed <- exists(".Random.seed", envir = .GlobalEnv))) {
	    oldSeed <- get(".Random.seed", envir = .GlobalEnv)
	    on.exit(assign(".Random.seed", oldSeed, envir = .GlobalEnv))
	} else {
	    oldRNG <- RNGkind()
	    on.exit(RNGkind(oldRNG[1], oldRNG[2]))
	}
	## set RNG
	if(is.logical(setRNG)) { # i.e. == TRUE: use the same as R CMD check
	    ## see ../../../../share/perl/massage-Examples.pl
	    RNGkind("default", "default")
	    set.seed(1)
	} else eval(setRNG)
    }
    source(zfile, local, echo = echo, prompt.echo = prompt.echo,
	   verbose = verbose, max.deparse.length = 250)
}
"fix" <-
    function (x, ...)
{
    subx <- substitute(x)
    if (is.name(subx))
        subx <- deparse(subx)
    if (!is.character(subx) || length(subx) != 1)
        stop("fix requires a name")
    parent <- parent.frame()
    if (exists(subx, envir=parent, inherits = TRUE))
        x <- edit(get(subx, envir=parent), ...)
    else {
        x <- edit(function(){},...)
        environment(x) <- .GlobalEnv
    }
    assign(subx, x, env = .GlobalEnv)
}

### placed in the public domain 2002
### Patrick Burns patrick@burns-stat.com

head <- function(x, ...) UseMethod("head")

head.default <- function(x, n=6, ...)
{
    ans <- x[seq(len=min(n, length(x)))]
    if(length(dim(x)) == 1) array(ans, n, list(names(ans))) else ans
}

head.data.frame <- head.matrix <- function(x, n=6, ...)
    x[seq(len=min(n, nrow(x))), , drop=FALSE]

head.function <- function(x, n=6, ...)
{
    lines <- as.matrix(deparse(x))
    dimnames(lines) <- list(seq(along=lines),"")
    noquote(head(lines, n=n))
}

tail <- function(x, ...) UseMethod("tail")

tail.default <- function(x, n=6, ...)
{
    xlen <- length(x)
    n <- min(n, xlen)
    ans <- x[seq(to=xlen, length=n)]
    if(length(dim(x)) == 1) array(ans, n, list(names(ans))) else ans
}

tail.data.frame <- tail.matrix <- function(x, n=6, ...)
{
    nrx <- nrow(x)
    x[seq(to=nrx, length=min(n, nrx)), , drop=FALSE]
}

tail.function <- function(x, n=6, ...)
{
    lines <- as.matrix(deparse(x))
    dimnames(lines) <- list(seq(along=lines),"")
    noquote(tail(lines, n=n))
}
help.search <-
function(pattern, fields = c("alias", "concept", "title"),
	 apropos, keyword, whatis, ignore.case = TRUE,
	 package = NULL, lib.loc = NULL,
	 help.db = getOption("help.db"),
	 verbose = getOption("verbose"),
	 rebuild = FALSE, agrep = NULL)
{
    ### Argument handling.
    TABLE <- c("alias", "concept", "keyword", "name", "title")

    if(!missing(pattern)) {
	if(!is.character(pattern) || (length(pattern) > 1))
	    stop(sQuote("pattern"), " must be a single character string")
	i <- pmatch(fields, TABLE)
	if(any(is.na(i)))
	    stop("incorrect field specification")
	else
	    fields <- TABLE[i]
    } else if(!missing(apropos)) {
	if(!is.character(apropos) || (length(apropos) > 1))
	    stop(sQuote("apropos"), " must be a single character string")
	else {
	    pattern <- apropos
	    fields <- c("alias", "title")
	}
    } else if(!missing(keyword)) {
	if(!is.character(keyword) || (length(keyword) > 1))
	    stop(sQuote("keyword"), " must be a single character string")
	else {
	    pattern <- keyword
	    fields <- "keyword"
            if(is.null(agrep)) agrep <- FALSE
	}
    } else if(!missing(whatis)) {
	if(!is.character(whatis) || (length(whatis) > 1))
	    stop(sQuote("whatis"), " must be a single character string")
	else {
	    pattern <- whatis
	    fields <- "alias"
	}
    } else {
	stop("don't know what to search")
    }

    if(is.null(lib.loc))
	lib.loc <- .libPaths()

    ## <FIXME>
    ## Currently, the information used for help.search is stored in
    ## package-level CONTENTS files.  As it is expensive to build the
    ## help.search db, we use a global file cache for this information
    ## if possible.  This is wrong because multiple processes or threads
    ## use the same cache (no locking!), and we should really save the
    ## information in one (thread-local) global table, e.g. as a local
    ## variable in the environment of help.search(), or something that
    ## can go in a 'shelf' (but not necessarily to a specific file) if
    ## memory usage is an issue.  Argh.
    ## </FIXME>

    ### Set up the help db.
    if(is.null(help.db) || !file.exists(help.db))
	rebuild <- TRUE
    else if(!rebuild) {
	## Try using the saved help db.
        db <- try(.readRDS(file = help.db), silent = TRUE)
        if(inherits(db, "try-error"))
            load(file = help.db)
	## If not a list (pre 1.7 format), rebuild.
	if(!is.list(db) ||
        ## If no information on concepts (pre 1.8 format), rebuild.
           length(db) < 4 ||
	## Need to find out whether this has the info we need.
	## Note that when looking for packages in libraries we always
	## use the first location found.  Hence if the library search
	## path changes we might find different versions of a package.
	## Thus we need to rebuild the help db in case the specified
	## library path is different from the one used when building the
	## help db (stored as its "LibPaths" attribute).
           !identical(lib.loc, attr(db, "LibPaths")) ||
	## We also need to rebuild the help db in case an existing dir
	## in the library path was modified more recently than the db,
	## as packages might have been installed or removed.
           any(file.info(help.db)$mtime <
	       file.info(lib.loc[file.exists(lib.loc)])$mtime)
           )
	    rebuild <- TRUE
    }
    if(rebuild) {
	## Check whether we can save the help db lateron.
	save.db <- FALSE
        dir <- file.path(tempdir(), ".R")
	dbfile <- file.path(dir, "help.db")
	if((tools::fileTest("-d", dir)
            || ((unlink(dir) == 0) && dir.create(dir)))
	   && (unlink(dbfile) == 0))
	    save.db <- TRUE

        ## If we cannot save the help db only use the given packages.
        ## <FIXME>
        ## Why don't we just use the given packages?  The current logic
        ## for rebuilding cannot figure out that rebuilding is needed
        ## the next time (unless we use the same given packages) ...
        packagesInHelpDB <- if(!is.null(package) && !save.db)
            package
        else
            .packages(all.available = TRUE, lib.loc = lib.loc)
        ## </FIXME>

	## Create the help db.
	contentsDCFFields <-
	    c("Entry", "Aliases", "Description", "Keywords")
        np <- 0
	if(verbose)
	    cat("Packages:\n")

        ## Starting with R 1.8.0, prebuilt hsearch indices are available
        ## in Meta/hsearch.rds, and the code to build this from the Rd
        ## contents (as obtained from both new and old style Rd indices)
        ## has been moved to tools:::.buildHsearchIndex(), which creates
        ## a per-package list of base, aliases and keywords information.
        ## When building the global index, it again (see e.g. also the
        ## code in tools:::Rdcontents()), it seems most efficient to
        ## create a list *matrix* (dbMat below), stuff the individual
        ## indices into its rows, and finally create the base, aliases
        ## and keyword information in rbind() calls on the columns.
        ## This is *much* more efficient than building incrementally.
        dbMat <- vector("list", length(packagesInHelpDB) * 4)
        dim(dbMat) <- c(length(packagesInHelpDB), 4)

	for(p in packagesInHelpDB) {
            np <- np + 1
	    if(verbose)
		cat("", p, if((np %% 5) == 0) "\n")
            ## skip stub packages
            if(p %in% c("ctest", "eda", "lqs", "mle", "modreg", "mva",
                        "nls", "stepfun", "ts")) next
	    path <- .find.package(p, lib.loc, quiet = TRUE)
	    if(length(path) == 0)
		stop("could not find package ", sQuote(p))

            if(file.exists(hsearchFile <-
                           file.path(path, "Meta", "hsearch.rds"))) {
                hDB <- .readRDS(hsearchFile)
            }
            else {
                hDB <- contents <- NULL
                ## Read the contents info from the respective Rd meta
                ## files.
                if(file.exists(contentsFile <-
                               file.path(path, "Meta", "Rd.rds"))) {
                    contents <- .readRDS(contentsFile)
                }
                else if(file.exists(contentsFile
                                    <- file.path(path, "CONTENTS"))) {
                    contents <-
                        read.dcf(contentsFile,
                                 fields = contentsDCFFields)
                }
                ## If we found Rd contents information ...
                if(!is.null(contents)) {
                    ## build the hsearch index from it;
                    hDB <- tools:::.buildHsearchIndex(contents, p,
                                                      dirname(path))
                }
                else {
                    ## otherwise, issue a warning.
                    warning("No Rd contents for package ",
                            sQuote(p), " in ", sQuote(dirname(path)))
                }
            }
            if(!is.null(hDB)) {
                ## Put the hsearch index for the np-th package into the
                ## np-th row of the matrix used for aggregating.
                dbMat[np, seq(along = hDB)] <- hDB
            }
        }

        if(verbose)
	    cat(ifelse(np %% 5 == 0, "\n", "\n\n"))

        ## Create the global base, aliases and keywords tables via calls
        ## to rbind() on the columns of the matrix used for aggregating.
        db <- list(Base = do.call("rbind", dbMat[, 1]),
                   Aliases = do.call("rbind", dbMat[, 2]),
                   Keywords = do.call("rbind", dbMat[, 3]),
                   Concepts = do.call("rbind", dbMat[, 4]))
        if(is.null(db$Concepts))
            db$Concepts <-
                matrix(character(), nc = 3,
                       dimnames = list(NULL,
                       c("Concepts", "ID", "Package")))
        ## And finally, make the IDs globally unique by prefixing them
        ## with the number of the package in the global index.
        for(i in which(sapply(db, NROW) > 0)) {
            db[[i]][, "ID"] <-
                paste(rep.int(seq(along = packagesInHelpDB),
                              sapply(dbMat[, i], NROW)),
                      db[[i]][, "ID"],
                      sep = "/")
        }

	## Maybe save the help db
	## <FIXME>
	## Shouldn't we serialize instead?
	if(save.db) {
	    attr(db, "LibPaths") <- lib.loc
	    .saveRDS(db, file = dbfile)
	    options(help.db = dbfile)
	}
	## </FIXME>
    }

    ### Matching.
    if(verbose)
	cat("Database of ",
	    NROW(db$Base), " Rd objects (",
	    NROW(db$Aliases), " aliases, ",
            NROW(db$Concepts), " concepts, ",
	    NROW(db$Keywords), " keywords),\n",
	    sep = "")
    if(!is.null(package)) {
	## Argument 'package' was given but we built a larger help db to
	## save for future invocations.	 Need to check that all given
	## packages exist, and only search the given ones.
	posInHelpDB <-
	    match(package, unique(db$Base[, "Package"]), nomatch = 0)
	if(any(posInHelpDB) == 0)
	    stop("could not find package ",
                 sQuote(package[posInHelpDB == 0][1]))
	db <-
	    lapply(db,
		   function(x) {
		       x[x[, "Package"] %in% package, , drop = FALSE]
		   })
    }

    ## <FIXME>
    ## No need continuing if there are no objects in the data base.
    ## But shouldn't we return something of class "hsearch"?
    if(!length(db$Base)) return(invisible())
    ## </FIXME>

    ## If agrep is NULL (default), we want to use fuzzy matching iff
    ## 'pattern' contains no characters special to regular expressions.
    ## We use the following crude approximation: if pattern contains
    ## only alphanumeric characters or whitespace or a '-', it is taken
    ## 'as is', and fuzzy matching is used unless turned off explicitly,
    ## or pattern has very few (currently, less than 5) characters.
    if(is.null(agrep) || is.na(agrep))
	agrep <-
	    ((regexpr("^([[:alnum:]]|[[:space:]]|-)+$", pattern) > 0)
             && (nchar(pattern) > 4))
    if(is.logical(agrep)) {
	if(agrep)
	    max.distance <- 0.1
    }
    else if(is.numeric(agrep) || is.list(agrep)) {
	max.distance <- agrep
	agrep <- TRUE
    }
    else
	stop("incorrect agrep specification")

    searchFun <- function(x) {
	if(agrep)
	    agrep(pattern, x, ignore.case = ignore.case,
		  max.distance = max.distance)
	else
	    grep(pattern, x, ignore.case = ignore.case)
    }
    dbBase <- db$Base
    searchDbField <- function(field) {
	switch(field,
	       alias = {
		   aliases <- db$Aliases
		   match(aliases[searchFun(aliases[, "Aliases"]),
                                 "ID"],
			 dbBase[, "ID"])
	       },
	       concept = {
		   concepts <- db$Concepts
		   match(concepts[searchFun(concepts[, "Concepts"]),
                                  "ID"],
			 dbBase[, "ID"])
	       },

	       keyword = {
		   keywords <- db$Keywords
		   match(keywords[searchFun(keywords[, "Keywords"]),
				  "ID"],
			 dbBase[, "ID"])
	       },
	       searchFun(db$Base[, field]))
    }

    i <- NULL
    for(f in fields) i <- c(i, searchDbField(f))
    db <- dbBase[sort(unique(i)),
		 c("topic", "title", "Package", "LibPath"),
		 drop = FALSE]
    if(verbose) cat("matched", NROW(db), "objects.\n")

    ## Retval.
    y <- list(pattern = pattern, fields = fields,
              type = if(agrep) "fuzzy" else "regexp",
              matches = db)
    class(y) <- "hsearch"
    y
}

print.hsearch <-
function(x, ...)
{
    fields <- paste(x$fields, collapse = " or ")
    type <- switch(x$type, fuzzy = "fuzzy", "regular expression")
    db <- x$matches
    if(NROW(db) > 0) {
	outFile <- tempfile()
	outConn <- file(outFile, open = "w")
	writeLines(c(strwrap(paste("Help files with", fields,
                                   "matching", sQuote(x$pattern),
                                   "using", type, "matching:")),
                     "\n\n"),
		   outConn)
	dbnam <- paste(db[ , "topic"], "(",
		       db[, "Package"], ")",
		       sep = "")
	dbtit <- paste(db[ , "title"], sep = "")
	writeLines(formatDL(dbnam, dbtit), outConn)
        writeLines(c("\n\n",
                     strwrap(paste("Type 'help(FOO, package = PKG)' to",
                                   "inspect entry 'FOO(PKG) TITLE'."))),
                   outConn)
	close(outConn)
	file.show(outFile, delete.file = TRUE)
    } else {
	writeLines(strwrap(paste("No help files found with", fields,
                                 "matching", sQuote(x$pattern),
                                 "using", type, "matching.")))
    }
}
loadhistory <- function(file=".Rhistory")
    invisible(.Internal(loadhistory(file)))

savehistory <- function(file=".Rhistory")
    invisible(.Internal(savehistory(file)))

history <- function(max.show=25, reverse=FALSE)
{
    file1 <- tempfile("Rrawhist")
    savehistory(file1)
    rawhist <- scan(file1, what = "", quiet=TRUE, sep="\n")
    unlink(file1)
    nlines <- length(rawhist)
    inds <- max(1, nlines-max.show):nlines
    if(reverse) inds <- rev(inds)
    file2 <- tempfile("hist")
    write(rawhist[inds], file2)
    file.show(file2, title="R History", delete.file=TRUE)
}
menu <- function(choices, graphics = FALSE, title = "")
{
    nc <- length(choices)
    cat(title, "\n")
    for (i in seq(length=nc))
	cat(i, ":", choices[i]," \n", sep = "")
    repeat {
	ind <- .Internal(menu(as.character(choices)))
	if(ind <= nc)
	    return(ind)
	cat("Enter an item from the menu, or 0 to exit\n")
    }
}
object.size <- function(x) .Internal(object.size(x))
## internal function used only in this file
findGeneric <- function(fname, envir)
{
    if(!exists(fname, mode = "function", envir = envir)) return("")
    f <- get(fname, mode = "function", envir = envir)
    if(.isMethodsDispatchOn() && methods::is(f, "genericFunction")) {
        ## maybe an S3 generic was turned into the S4 default
        fdeflt <- methods::finalDefaultMethod(methods::getMethodsForDispatch(fname, f))
        if(methods::is(fdeflt, "derivedDefaultMethod"))
            f <- fdeflt
        else
            warning(sQuote(fname), " is a formal generic function; S3 methods will not likely be found")
    }
    isUMEbrace <- function(e) {
        for (ee in as.list(e[-1]))
            if (nchar(res <- isUME(ee))) return(res)
        ""
    }
    isUMEif <- function(e) {
        if (length(e) == 3) isUME(e[[3]])
        else {
            if (nchar(res <- isUME(e[[3]]))) res
            else if (nchar(res <- isUME(e[[4]]))) res
            else ""
        }
    }
    isUME <- function(e) {
        if (is.call(e) && (is.name(e[[1]]) || is.character(e[[1]]))) {
            switch(as.character(e[[1]]),
                   UseMethod = as.character(e[[2]]),
                   "{" = isUMEbrace(e),
                   "if" = isUMEif(e),
                   "")
        } else ""
    }
    isUME(body(f))
}

methods <- function (generic.function, class)
{
    rbindSome <- function(df, nms, msg) {
        ## rbind.data.frame() -- dropping rows with duplicated names
        n2 <- length(nms)
        dnew <- data.frame(visible = rep.int(FALSE, n2),
                           from    = rep.int(msg,   n2),
                           row.names = nms)
        n <- nrow(df)
        if(n == 0) return(dnew)
        ## else
        keep <- !duplicated(c(rownames(df), rownames(dnew)))
        rbind(df  [keep[1:n] , ],
              dnew[keep[(n+1):(n+n2)] , ])
    }

    S3MethodsStopList <- tools:::.makeS3MethodsStopList(NULL)
    knownGenerics <- c(names(.knownS3Generics),
                       tools:::.getInternalS3generics())

    an <- lapply(seq(along=(sp <- search())), ls)
    names(an) <- sp
    an <- unlist(an)
    an <- an[!duplicated(an)] # removed masked objects, *keep* names
    names(an) <- sub("[0-9]*$", "", names(an))
    info <- data.frame(visible = rep.int(TRUE, length(an)),
                       from = names(an),
                       row.names = an)
    if (!missing(generic.function)) {
	if (!is.character(generic.function))
	    generic.function <- deparse(substitute(generic.function))
        if(!any(generic.function == knownGenerics)) {
            truegf <- findGeneric(generic.function, parent.frame())
            if(nchar(truegf) && truegf != generic.function) {
                warning(paste("Generic", sQuote(generic.function),
                              "dispatches methods for generic",
                              sQuote(truegf)))
                generic.function <- truegf
            }
        }
	name <- paste("^", generic.function, ".", sep = "")
        name <- gsub("([.[$+*])", "\\\\\\1",name)
        info <- info[grep(name, row.names(info)), ]
        info <- info[! row.names(info) %in% S3MethodsStopList, ]
        ## check that these are all functions
        ## might be none at this point
        if(nrow(info)) {
            keep <- sapply(row.names(info),
                           function(nm) exists(nm, mode="function"))
            info <- info[keep, ]
        }

        ## also look for registered methods from namespaces
        ## we assume that only functions get registered.
        defenv <- if(!is.na(w <- .knownS3Generics[generic.function]))
            asNamespace(w)
        else {
            genfun <- get(generic.function, mode = "function",
                          envir = parent.frame())
            if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction"))
                genfun <- methods::slot(genfun, "default")@methods$ANY
            if (typeof(genfun) == "closure") environment(genfun)
            else .BaseNamespaceEnv
        }
        S3reg <- ls(get(".__S3MethodsTable__.", envir = defenv),
                    pattern = name)
        if(length(S3reg))
            info <- rbindSome(info, S3reg, msg =
                              paste("registered S3method for",
                                    generic.function))
        ## both all() and all.equal() are generic, so
        if(generic.function == "all")
            info <- info[-grep("^all\\.equal", row.names(info)), ]
    }
    else if (!missing(class)) {
	if (!is.character(class))
	    class <- paste(deparse(substitute(class)))
	name <- paste(".", class, "$", sep = "")
        name <- gsub("([.[])", "\\\\\\1", name)
        info <- info[grep(name, row.names(info)), ]
        info <- info[! row.names(info) %in% S3MethodsStopList, ]

        if(nrow(info)) {
            ## check if we can find a generic matching the name
            possible.generics <- gsub(name, "", row.names(info))
            keep <- sapply(possible.generics, function(nm) {
                if(nm %in% knownGenerics) return(TRUE)
                where <- find(nm, mode = "function")
                if(!length(where)) return(FALSE)
                any(sapply(where, function(w)
                           nchar(findGeneric(nm, envir=as.environment(w))) > 0))
            })
            info <- info[keep, ]
        }

        ## also look for registered methods in loaded namespaces.
        ## These should only be registered in environments containing
        ## the corresponding generic, so we don't check again.
        ## Note that the generic will not necessarily be visible,
        ## as the package may not be loaded.
        S3reg <- unlist(lapply(loadedNamespaces(), function(i) ls(get(".__S3MethodsTable__.", envir = asNamespace(i)), pattern = name)))
        ## now methods like print.summary.aov will be picked up,
        ## so we do look for such mismatches.
        if(length(S3reg))
            S3reg <- S3reg[sapply(gsub(name, "", S3reg), exists)]
        if(length(S3reg))
            info <- rbindSome(info, S3reg, msg = "registered S3method")
    }
    else stop("must supply generic.function or class")

    info <- info[sort.list(row.names(info)), ]
    res <- row.names(info)
    class(res) <- "MethodsFunction"
    attr(res, "info") <- info
    res
}

print.MethodsFunction <- function(x, ...)
{
    visible <- attr(x, "info")[["visible"]]
    if(length(x)) {
        print(paste(x, ifelse(visible, "", "*"), sep=""), quote=FALSE, ...)
        if(any(!visible))
            cat("\n    Non-visible functions are asterisked\n")
    } else cat("no methods were found\n")
    invisible(x)
}


getS3method <-  function(f, class, optional = FALSE)
{
    knownGenerics <- c(tools:::.getInternalS3generics(),
                       names(.knownS3Generics))
    if(!any(f == knownGenerics)) {
        truegf <- findGeneric(f, parent.frame())
        if(nchar(truegf)) f <- truegf
        else {
            if(optional) return(NULL)
            else stop("no function '", f, "' could be found")
        }
    }
    method <- paste(f, class, sep=".")
    if(exists(method, mode = "function", envir = parent.frame()))
        return(get(method, mode = "function", envir = parent.frame()))
    ## also look for registered method in namespaces
    defenv <- if(!is.na(w <- .knownS3Generics[f])) asNamespace(w)
    else if(f %in% tools:::.getInternalS3generics()) .BaseNamespaceEnv
    else {
        genfun <- get(f, mode="function", envir = parent.frame())
        if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction"))
            genfun <- methods::slot(genfun, "default")@methods$ANY
        if (typeof(genfun) == "closure") environment(genfun)
        else .BaseNamespaceEnv
    }
    S3Table <- get(".__S3MethodsTable__.", envir = defenv)
    S3reg <- ls(S3Table)
    if(length(grep(gsub("([.[$])", "\\\\\\1", method), S3reg)))
        return(get(method, envir = S3Table))
    if(optional) NULL else stop("S3 method ", method, " not found")
}

getFromNamespace <- function(x, ns, pos = -1, envir = as.environment(pos))
{
    if(missing(ns)) {
        nm <- attr(envir, "name")
        if(is.null(nm) || substring(nm, 1, 8) != "package:")
            stop("environment specified is not a package")
        ns <- asNamespace(substring(nm, 9))
    } else ns <- asNamespace(ns)
    get(x, envir = ns, inherits = FALSE)
}

assignInNamespace <-
    function(x, value, ns, pos = -1, envir = as.environment(pos))
{
    if(missing(ns)) {
        nm <- attr(envir, "name")
        if(is.null(nm) || substring(nm, 1, 8) != "package:")
            stop("environment specified is not a package")
        ns <- asNamespace(substring(nm, 9))
    } else ns <- asNamespace(ns)
    if(bindingIsLocked(x, ns)) {
        unlockBinding(x, ns)
        assign(x, value, envir = ns, inherits = FALSE)
        w <- options("warn")
        on.exit(options(w))
        options(warn = -1)
        lockBinding(x, ns)
    } else {
        assign(x, value, envir = ns, inherits = FALSE)
    }
    if(!isBaseNamespace(ns)) {
        ## now look for possible copy as a registered S3 method
        S3 <- getNamespaceInfo(ns, "S3methods")
        if(!length(S3)) return(invisible(NULL))
        S3names <- S3[, 3]
        if(x %in% S3names) {
            i <- match(x, S3names)
            genfun <- get(S3[i, 1], mode = "function", envir = parent.frame())
            if(.isMethodsDispatchOn() && methods::is(genfun, "genericFunction"))
                genfun <- methods::slot(genfun, "default")@methods$ANY
            defenv <- if (typeof(genfun) == "closure") environment(genfun)
            else .BaseNamespaceEnv
            S3Table <- get(".__S3MethodsTable__.", envir = defenv)
            remappedName <- paste(S3[i, 1], S3[i, 2], sep = ".")
            if(exists(remappedName, envir = S3Table, inherits = FALSE))
                assign(remappedName, value, S3Table)
        }
    }
    invisible(NULL)
}

fixInNamespace <- function (x, ns, pos = -1, envir = as.environment(pos), ...)
{
    subx <- substitute(x)
    if (is.name(subx))
        subx <- deparse(subx)
    if (!is.character(subx) || length(subx) != 1)
        stop("fixInNamespace requires a name")
    if(missing(ns)) {
        nm <- attr(envir, "name")
        if(is.null(nm) || substring(nm, 1, 8) != "package:")
            stop("environment specified is not a package")
        ns <- asNamespace(substring(nm, 9))
    } else ns <- asNamespace(ns)
    x <- edit(get(subx, envir = ns, inherits = FALSE), ...)
    assignInNamespace(subx, x, ns)
}

getAnywhere <- function(x)
{
    x <- as.character(substitute(x))
    objs <- list(); where <- character(0); visible <- logical(0)
    ## first look on search path
    if(length(pos <- find(x, numeric=TRUE))) {
        objs <- lapply(pos, function(pos, x) get(x, pos=pos), x=x)
        where <- names(pos)
        visible <- rep.int(TRUE, length(pos))
    }
    ## next look for methods
    if(length(grep(".", x, fixed=TRUE))) {
        np <- length(parts <- strsplit(x, ".", fixed=TRUE)[[1]])
        for(i in 2:np) {
            gen <- paste(parts[1:(i-1)], collapse=".")
            cl <- paste(parts[i:np], collapse=".")
            if(!is.null(f <- getS3method(gen, cl, TRUE))) {
                ev <- topenv(environment(f), NULL)
                nmev <- if(isNamespace(ev)) getNamespaceName(ev) else NULL
                objs <- c(objs, f)
                msg <- paste("registered S3 method for", gen)
                if(!is.null(nmev))
                    msg <- paste(msg, "from namespace", nmev)
                where <- c(where, msg)
                visible <- c(visible, FALSE)
            }
        }
    }
    ## now look in namespaces, visible or not
    for(i in loadedNamespaces()) {
        ns <- asNamespace(i)
        if(exists(x, envir = ns, inherits = FALSE)) {
            f <- get(x, envir = ns, inherits = FALSE)
            objs <- c(objs, f)
            where <- c(where, paste("namespace", i, sep=":"))
            visible <- c(visible, FALSE)
        }
    }
    # now check for duplicates
    ln <- length(objs)
    dups <- rep.int(FALSE, ln)
    objs2 <- lapply(objs, function(x) {
        if(is.function(x)) environment(x) <- NULL
        x
    })
    if(ln > 1)
        for(i in 2:ln)
            for(j in 1:(i-1))
                if(identical(objs2[[i]], objs2[[j]])) {
                    dups[i] <- TRUE
                    break
                }
    res <- list(name=x, objs=objs, where=where, visible=visible, dups=dups)
    class(res) <- "getAnywhere"
    res
}

print.getAnywhere <- function(x, ...)
{
    n <- sum(!x$dups)
    if(n == 0) {
        cat("no object named", sQuote(x$name), "was found\n")
    } else if (n == 1) {
        cat("A single object matching", sQuote(x$name), "was found\n")
        cat("It was found in the following places\n")
        cat(paste("  ", x$where, sep=""), sep="\n")
        cat("with value\n\n")
        print(x$objs[[1]])
    } else {
        cat(n, "differing objects matching", sQuote(x$name),
            "were found\n")
        cat("in the following places\n")
        cat(paste("  ", x$where, sep=""), sep="\n")
        cat("Use [] to view one of them\n")
    }
    invisible(x)
}

"[.getAnywhere" <- function(x, i)
{
    if(!is.numeric(i)) stop("only numeric indices can be used")
    if(length(i) == 1) x$objs[[i]]
    else x$objs[i]
}
package.skeleton <-
function(name = "anRpackage", list, environment = .GlobalEnv,
         path = ".", force = FALSE)
{
    safe.dir.create <- function(path)
    {
        dirTest <- function(x) !is.na(isdir <- file.info(x)$isdir) & isdir
        if(!dirTest(path) && !dir.create(path))
            stop("cannot create directory ", sQuote(path))
    }

    if(missing(list))
        list<-ls(env=environment)

    if(!is.character(list))
        stop("'list' should be a character vector naming R objects")
    have <- sapply(list, exists)
    if(any(!have))
        warning("object(s) ", paste(sQuote(list[!have]), collapse=", "),
                " not found")
    list <- list[have]
    if(!length(list))
        stop("no R objects specified or available")

    cat("Creating directories ...\n")
    ## Make the directories
    if(file.exists(file.path(path,name)) && !force)
        stop(paste("Directory", name, "exists."))

    safe.dir.create(file.path(path, name))
    safe.dir.create(file.path(path, name, "man"))
    safe.dir.create(file.path(path, name, "src"))
    safe.dir.create(file.path(path, name, "R"))
    safe.dir.create(file.path(path, name, "data"))

    ## DESCRIPTION
    cat("Creating DESCRIPTION ...\n")
    description <- file(file.path(path, name, "DESCRIPTION"), "wt")
    cat("Package: the_name_of_the_package\n",
        "Title: What the package does\n",
        "Version: 1.0\n",
        "Author: Who wrote it\n",
        "Description: More about what it does\n",
        "Maintainer: Who to complain to <yourfault@somewhere.net>\n",
        "License: What license is it under?\n",
        file = description, sep = "")
    close(description)

    ## READMEs
    cat("Creating READMEs ...\n")

    ## src/README
    readme <- file(file.path(path, name, "src", "README"), "wt")
    cat("Put C/C++/Fortran code here.\n",
        "If you have compiled code, add a .First.lib() function\n",
        "in the 'R' subdirectory to load it.\n",
        file = readme, sep = "")
    close(readme)

    ## man/README
    readme <- file(file.path(path, name, "man", "README"), "wt")
    cat("Edit these help files.\n",
        "You may want to combine the help files for multiple functions.\n",
        file = readme, sep = "")
    close(readme)

    readme <- file(file.path(path, name, "README"), "wt")
    cat("1. Put any C/C++/Fortran code in 'src'\n",
        "2. If you have compiled code, add a .First.lib() function in 'R'\n",
        "   to load the shared library\n",
        "3. Edit the help file skeletons in 'man'\n",
        "4. Run R CMD build to create the index files\n",
        "5. Run R CMD check to check the package\n",
        "6. Run R CMD build to make the package file\n",
        "\n\nRead \"Writing R Extensions\" for more information.\n",
        file = readme, sep = "")
    close(readme)

    internalObjInds <- grep("^\\.", list)
    internalObjs <- list[internalObjInds]
    if(any(internalObjInds))
        list <- list[-internalObjInds]

    ## Some object names may not be valid file names, especially replacement
    ## function names. And if we start changing them they may collide.
    list0 <- gsub("[[:cntrl:]\"*/:<>?\\|]", "_", list)
    wrong <- grep("^(con|prn|aux|clock\\$|nul|lpt[1-3]|com[1-4])(\\..*|)$",
                  list0)
    if(length(wrong)) list0[wrong] <- paste("zz", list0[wrong], sep="")
    ## now on Windows lower/uppercase will collide too
    list1 <- tolower(list0)
    list2 <- make.unique(list1, sep="_")
    changed <- (list2 != list1)
    list0[changed] <- list2[changed]
    names(list0) <- list

    ## Dump the items in 'data' or 'R'
    cat("Saving functions and data ...\n")
    if(any(internalObjInds))
        dump(internalObjs,
             file = file.path(path, name, "R",
                              paste(name, "-internal.R", sep = "")))
    for(item in list){
        if(is.function(get(item)))
            dump(item,
                 file = file.path(path, name, "R",
                                  paste(list0[item], "R", sep = ".")))
        else # we cannot guarantee this is a valid file name
            try(save(list = item,
                     file = file.path(path, name, "data",
                                      paste(item, "rda", sep = "."))))
    }

    ## Make help file skeletons in 'man'
    cat("Making help files ...\n")
    if(any(internalObjInds)) {
        Rdfile <- file(file.path(path, name, "man",
                                 paste(name, "-internal.Rd", sep = "")),
                       "wt")
        cat("\\name{", name, "-internal}\n",
            "\\title{Internal ", name, " objects}\n",
            file = Rdfile, sep = "")
        for(item in internalObjs) {
            cat("\\alias{", item, "}\n", file = Rdfile, sep = "")
        }
        cat("\\description{Internal ", name, " objects.}\n",
            "\\details{These are not to be called by the user.}\n",
            "\\keyword{internal}",
            file = Rdfile, sep = "")
        close(Rdfile)
    }
    ## Redirect output so that we do not see the partially inappropriate
    ## messages from prompt().
    outFile <- tempfile()
    outConn <- file(outFile, "w")
    sink(outConn, type = "output")
    yy <- try(sapply(list,
                     function(item) {
                         prompt(item,
                                filename = file.path(path, name, "man",
                                paste(list0[item], "Rd", sep=".")))
                     }))
    sink(type = "output")
    close(outConn)
    unlink(outFile)
    if(inherits(yy, "try-error"))
        stop(yy)

    ## Now we may have created an empty data or R directory
    Rdir <- file.path(path, name, "R")
    if(length(list.files(Rdir)) == 0) unlink(Rdir, recursive=TRUE)
    datadir <- file.path(path, name, "data")
    if(length(list.files(datadir)) == 0) unlink(datadir, recursive=TRUE)

    cat("Done.\n")
    cat(paste("Further steps are described in",
              file.path(path, name, "README"),
              "\n"))
}
packageStatus <- function(lib.loc = NULL,
                           repositories = getOption("repositories")())
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()
    if(is.null(repositories))
        repositories <- contrib.url(c(CRAN = getOption("CRAN"),
                                      BIOC = getOption("BIOC")))

    FIELDS <- c("Package", "Version","Priority", "Bundle", "Depends",
                "Built", "Status")
    FIELDS1 <- c(FIELDS, "LibPath")
    FIELDS2 <- c(FIELDS, "Repository")

    ## convert character matrices to dataframes
    char2df <- function(x)
    {
        y <- list()
        for(k in 1:ncol(x)) y[[k]] <- x[,k]
        attr(y, "names") <- colnames(x)
        attr(y, "row.names") <- 1:nrow(x)
        class(y) <- "data.frame"
        y
    }

    y <- NULL
    for(lib in lib.loc)
    {
        pkgs <- .packages(all.available=TRUE, lib.loc = lib)
        for(p in pkgs){
            desc <- unlist(packageDescription(p, lib=lib, fields=FIELDS))
            desc["Package"] <-
                ifelse(is.na(desc["Bundle"]),
                       desc["Package"],
                       paste(desc["Bundle"], desc["Package"], sep=":"))
            y <- rbind(y, c(desc, lib))
        }
    }

    y[,"Status"] <- "ok"
    y <- char2df(y)
    names(y) <- FIELDS1

    if(length(repositories) > 0){
        repositories <- unique(as.character(repositories))
        z <- matrix("", nrow=0, ncol=length(FIELDS2))
        colnames(z) <- FIELDS2
        for(rep in repositories){
            z1 <- try(read.dcf(paste(rep,"PACKAGES",sep="/"),
                               fields=FIELDS2), silent=TRUE)
            if(inherits(z1, "try-error")) {
                cat("Warning: unable to access index for repository", rep, "\n")
                repositories <- repositories[repositories != rep]
                next
            }

            ## ignore packages which don't fit our version of R
            z1 <- z1[package.dependencies(z1, check=TRUE),,drop=FALSE]
            if(length(z1)==0) next

            z1[,"Repository"] <- rep
            z <- rbind(z[,FIELDS2], z1[,FIELDS2])
        }
    }

    ## only consider the newest version of each package
    ## in the first repository where it appears
    ztab <- table(z[,"Package"])
    for(pkg in names(ztab)[ztab>1]){
        zrow <- which(z[,"Package"]==pkg)
        znewest <- newestVersion(z[zrow,"Version"])
        ## and now exclude everything but the newest
        z <- z[-zrow[-znewest],]
    }

    z[,"Status"] <- "not installed"
    z[z[,"Package"] %in% y$Package, "Status"] <- "installed"
    z[!is.na(z[,"Bundle"]) & (z[,"Bundle"] %in% y$Bundle),
      "Status"] <- "installed"

    z <- char2df(z)
    z$Package <- ifelse(is.na(z$Bundle), z$Package, z$Bundle)
    attr(z, "row.names") <- z$Package

    for(k in 1:nrow(y)){
        pkg <- ifelse(is.na(y$Bundle[k]),
                      y[k,"Package"],
                      y[k,"Bundle"])

        if(pkg %in% z$Package){
            if(compareVersion(y[k,"Version"],
                              z[pkg,"Version"]) < 0){
                y[k,"Status"] <- "upgrade"
            }
        }
        else{
            if(!(y[k,"Priority"] %in% "base"))
                y[k,"Status"] <- "unavailable"
        }
    }

    y$LibPath <- factor(as.character(y$LibPath), levels=lib.loc)
    y$Status <- as.factor(y$Status)
    z$Repository <- factor(as.character(z$Repository), levels=repositories)
    z$Status <- as.factor(z$Status)

    retval <- list(inst=y, avail=z)
    class(retval) <- c("packageStatus")
    retval
}

summary.packageStatus <- function(object, ...)
{
    cat("\nInstalled packages:\n")
    cat(  "-------------------\n")
    for(k in levels(object$inst$LibPath)){
        ok <- (object$inst$LibPath==k)
        cat("\n*** Library ", k, "\n", sep="")
        if(any(ok)){
            print(tapply(object$inst$Package[ok],
                         object$inst$Status[ok],
                         function(x) sort(as.character(x))))
        }
    }
    cat("\n\nAvailable packages:\n")
    cat(    "-------------------\n")
    cat("(each package appears only once)\n")
    for(k in levels(object$avail$Repository)){
        cat("\n*** Repository ", k, "\n", sep="")
        ok <- object$avail$Repository==k
        if(any(ok))
            print(tapply(object$avail$Package[ok],
                         object$avail$Status[ok],
                         function(x) sort(as.character(x))))
    }
    invisible(object)
}

print.packageStatus <- function(x, ...)
{
    cat("Number of installed packages:\n")
    print(table(x$inst$LibPath, x$inst$Status))

    cat("\nNumber of available packages (each package counted only once):\n")
    print(table(x$avail$Repository, x$avail$Status))
    invisible(x)
}

newestVersion <- function(x)
{
    ## only used for length(x) >= 2
    for(k in 1:length(x)){
        if(length(x) == 1) return(k)
        y <- sapply(x[-1], compareVersion, b=x[1])
        if(all(y <= 0))
            return(k)
        else
            x <- x[-1]
    }
}

update.packageStatus <-
    function(object, lib.loc=levels(object$inst$LibPath),
             repositories=levels(object$avail$Repository),
             ...)
{
    packageStatus(lib.loc=lib.loc, repositories=repositories)
}


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

upgrade.packageStatus <- function(object, ask=TRUE, ...){

    update <- NULL
    old <- which(object$inst$Status=="upgrade")
    if(length(old)==0){
        cat("Nothing to do!\n")
        return(invisible())
    }

    askprint <- function(x)
        write.table(x, row.names=FALSE, col.names=FALSE, quote=FALSE,
                    sep=" at ")

    haveasked <- character(0)
    if(ask){
        for(k in old){
            pkg <- ifelse(is.na(object$inst[k,"Bundle"]),
                          object$inst[k,"Package"],
                          object$inst[k,"Bundle"])
            tmpstring <- paste(pkg, as.character(object$inst[k,"LibPath"]))
            if(tmpstring %in% haveasked) next
            haveasked <- c(haveasked, tmpstring)
            cat("\n")
            cat(pkg, ":\n")
            askprint(object$inst[k,c("Version","LibPath")])
            askprint(object$avail[pkg, c("Version", "Repository")])
            answer <- substr(readline("Update (y/N)?  "), 1, 1)
            if(answer == "y" | answer == "Y")
                update <-
                    rbind(update,
                          c(pkg, as.character(object$inst[k,c("LibPath")]),
                            as.character(object$avail[pkg,c("Repository")])))
        }
    }
    else
        update <- old

    if(length(update)>0){
        for(repo in unique(update[,3])){
            ok <- update[,3]==repo
            install.packages(update[ok,1], update[ok,2],
                             contriburl=repo)
        }
    }
}





CRAN.packages <- function(CRAN=getOption("CRAN"), method,
                          contriburl=contrib.url(CRAN))
{
    localcran <- length(grep("^file:", contriburl)) > 0
    if(localcran)
        tmpf <- paste(substring(contriburl,6), "PACKAGES", sep="/")
    else{
        tmpf <- tempfile()
        on.exit(unlink(tmpf))
        download.file(url=paste(contriburl, "PACKAGES", sep="/"),
                      destfile=tmpf, method=method, cacheOK=FALSE)
    }
    read.dcf(file=tmpf, fields=c("Package", "Version",
                       "Priority", "Bundle", "Depends"))
}

update.packages <- function(lib.loc=NULL, CRAN=getOption("CRAN"),
                            contriburl=contrib.url(CRAN),
                            method, instlib=NULL, ask=TRUE,
                            available=NULL, destdir=NULL,
			    installWithVers=FALSE)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()

    if(is.null(available))
        available <- CRAN.packages(contriburl=contriburl, method=method)

    old <- old.packages(lib.loc=lib.loc,
                        contriburl=contriburl,
                        method=method,
                        available=available)

    update <- NULL
    if(ask & !is.null(old)){
        for(k in 1:nrow(old)){
            cat(old[k, "Package"], ":\n",
                "Version", old[k, "Installed"],
                "in", old[k, "LibPath"], "\n",
                "Version", old[k, "CRAN"], "on CRAN")
            cat("\n")
            answer <- substr(readline("Update (y/N)?  "), 1, 1)
            if(answer == "y" | answer == "Y")
                update <- rbind(update, old[k,])
        }
    }
    else
        update <- old


    if(!is.null(update)){
        if(is.null(instlib))
            instlib <-  update[,"LibPath"]

        install.packages(update[,"Package"], instlib,
                         contriburl=contriburl,
                         method=method,
                         available=available, destdir=destdir,
                         installWithVers=installWithVers)
    }
}

old.packages <- function(lib.loc=NULL, CRAN=getOption("CRAN"),
                         contriburl=contrib.url(CRAN),
                         method, available=NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()

    instp <- installed.packages(lib.loc=lib.loc)
    if(is.null(dim(instp)))
        stop("no installed.packages for (invalid?) lib.loc=",lib.loc)
    if(is.null(available))
        available <- CRAN.packages(contriburl=contriburl, method=method)

    ## for bundles it is sufficient to install the first package
    ## contained in the bundle, as this will install the complete bundle
    ## However, a bundle might be installed in more than one place.
    for(b in unique(instp[,"Bundle"])){
        if(!is.na(b))
            for (w in unique(instp[,"LibPath"])) {
            ok <- which(instp[,"Bundle"] == b & instp[,"LibPath"] == w)
            if(length(ok)>1) instp <- instp[-ok[-1],]
        }
    }

    ## for packages contained in bundles use bundle names from now on
    ok <- !is.na(instp[,"Bundle"])
    instp[ok,"Package"] <- instp[ok,"Bundle"]
    ok <- !is.na(available[,"Bundle"])
    available[ok,"Package"] <- available[ok,"Bundle"]

    update <- NULL

    newerVersion <- function(a, b){
        a <- as.integer(strsplit(a, "[\\.-]")[[1]])
        b <- as.integer(strsplit(b, "[\\.-]")[[1]])
        if(any(is.na(a)))
            return(FALSE)
        if(any(is.na(b)))
            return(TRUE)
        for(k in 1:length(a)){
            if(k <= length(b)){
                if(a[k]>b[k])
                    return(TRUE)
                else if(a[k]<b[k])
                    return(FALSE)
            }
            else{
                return(TRUE)
            }
        }
        return(FALSE)
    }

    for(k in 1:nrow(instp)){
        ok <- (!(instp[k, "Priority"] %in% "base")) &
                (available[,"Package"] == instp[k, "Package"])
        if(any(ok))
            ok[ok] <- sapply(available[ok, "Version"], newerVersion,
                             instp[k, "Version"])
        if(any(ok) && any(package.dependencies(available[ok, ], check=TRUE)))
        {
            update <- rbind(update,
                            c(instp[k, c("Package", "LibPath", "Version")],
                              available[ok, "Version"]))
        }
    }
    if(!is.null(update))
        colnames(update) <- c("Package", "LibPath",
                              "Installed", "CRAN")
    update
}

installed.packages <- function(lib.loc = NULL, priority = NULL)
{
    if(is.null(lib.loc))
        lib.loc <- .libPaths()
    pkgFlds <- c("Version", "Priority", "Bundle", "Depends")
    if(!is.null(priority)) {
        if(!is.character(priority))
            stop("`priority' must be character or NULL")
        if(any(b <- priority %in% "high"))
            priority <- c(priority[!b], "recommended","base")
    }
    retval <- character()
    for(lib in lib.loc) {
        pkgs <- .packages(all.available=TRUE, lib.loc = lib)
        for(p in pkgs){
            desc <- unlist(packageDescription(p, lib=lib, fields= pkgFlds))
            if(!is.null(priority)) # skip if priority does not match
                if(is.na(pmatch(desc["Priority"], priority))) next
            retval <- rbind(retval, c(p, lib, desc))
        }
    }
    if (length(retval))
        colnames(retval) <- c("Package", "LibPath", pkgFlds)
    retval
}

remove.packages <- function(pkgs, lib, version) {

    updateIndices <- function(lib) {
        ## This should eventually be made public, as it could also be
        ## used by install.packages() && friends.
        if(lib == .Library) {
            ## R version of
            ##   ${R_HOME}/bin/build-help --htmllists
            ##   cat ${R_HOME}/library/*/CONTENTS \
            ##     > ${R_HOME}/doc/html/search/index.txt
            if(exists("link.html.help", mode = "function"))
                link.html.help()
        }
    }

    if(missing(lib) || is.null(lib)) {
        lib <- .libPaths()[1]
        warning(paste("argument `lib' is missing: using", lib))
    }

    if (!missing(version))
        pkgs <- manglePackageName(pkgs, version)

    paths <- .find.package(pkgs, lib)
    unlink(paths, TRUE)
    for(lib in unique(dirname(paths)))
        updateIndices(lib)
}

page <- function(x, method = c("dput", "print"), ...)
{
    subx <- substitute(x)
    if( is.name(subx) )
	subx <- deparse(subx)
    if (!is.character(subx) || length(subx) != 1)
	stop("page requires a name")
    method <- match.arg(method)
    parent <- parent.frame()
    if(exists(subx, envir = parent, inherits=TRUE)) {
        file <- tempfile("Rpage.")
        if(method == "dput")
            dput(get(subx, envir = parent, inherits=TRUE), file)
        else {
            sink(file)
            print(get(subx, envir = parent, inherits=TRUE))
            sink()
        }
	file.show(file, title = subx, delete.file = TRUE, ...)
    } else
	stop(paste("no object named \"", subx, "\" to edit",sep=""))
}
prompt <-
function(object, filename = NULL, name = NULL, ...)
    UseMethod("prompt")

prompt.default <-
function(object, filename = NULL, name = NULL,
         force.function = FALSE, ...)
{
    paste0 <- function(...) paste(..., sep = "")

    is.missing.arg <- function(arg)
        typeof(arg) == "symbol" && deparse(arg) == ""

    if(missing(name))
        name <-
            if(is.character(object))
                object
            else {
                name <- substitute(object)
                if(is.language(name) && !is.name(name))
                    name <- eval(name)
                as.character(name)
            }
    if(is.null(filename))
        filename <- paste0(name, ".Rd")

    ## Better than get(); works when called in fun :
    x <- get(name, envir = parent.frame())

    ## <FIXME>
    ## If not a function or forced to document a function (?), always
    ## assume data set.
    if(!(is.function(x) || force.function))
        return(promptData(x, filename = filename, name = name))
    ## </FIXME>

    s <- seq(length = n <- length(argls <- formals(x)))
    if(n > 0) {
        arg.names <- arg.n <- names(argls)
        arg.n[arg.n == "..."] <- "\\dots"
    }
    ## Construct the 'call' for \usage.
    call <- paste0(name, "(")
    for(i in s) {                       # i-th argument
        call <- paste0(call, arg.names[i],
                       if(!is.missing.arg(argls[[i]]))
                       paste0(" = ",
                              deparse(argls[[i]], width.cutoff= 500)))
        if(i != n) call <- paste0(call, ", ")
    }

    ## Construct the definition for \examples.
    x.def <- attr(x, "source")
    if(is.null(x.def))
        x.def <- deparse(x)
    if(any(br <- substr(x.def, 1, 1) == "}"))
        x.def[br] <- paste(" ", x.def[br])

    Rdtxt <-
        list(name = paste0("\\name{", name, "}"),
             aliases = c(paste0("\\alias{", name, "}"),
             paste("%- Also NEED an '\\alias' for EACH other topic",
                   "documented here.")),
             title = "\\title{ ~~function to do ... ~~ }",
             description = c("\\description{",
             paste("  ~~ A concise (1-5 lines) description of what",
                   "the function does. ~~"),
             "}"),
             usage = c("\\usage{", paste0(call, ")"), "}",
             paste("%- maybe also 'usage' for other objects",
                   "documented here.")),
             arguments = NULL,
             details = c("\\details{",
             paste("  ~~ If necessary, more details than the",
                   "__description__  above ~~"),
             "}"),
             value = c("\\value{",
             "  ~Describe the value returned",
             "  If it is a LIST, use",
             "  \\item{comp1 }{Description of 'comp1'}",
             "  \\item{comp2 }{Description of 'comp2'}",
             "  ...",
             "}"),
             references = paste("\\references{ ~put references to the",
             "literature/web site here ~ }"),
             author = "\\author{ ~~who you are~~ }",
             note = c("\\note{ ~~further notes~~ }",
             "",
             paste(" ~Make other sections like Warning with",
                   "\\section{Warning }{....} ~"),
             ""),
             seealso = paste("\\seealso{ ~~objects to See Also as",
             "\\code{\\link{~~fun~~}}, ~~~ }"),
             examples = c("\\examples{",
             "##---- Should be DIRECTLY executable !! ----",
             "##-- ==>  Define data, use random,",
             "##--	or do  help(data=index)  for the standard data sets.",
             "",
             "## The function is currently defined as",
             x.def,
             "}"),
             keywords = c(paste("\\keyword{ ~kwd1 }% at least one,",
             "from doc/KEYWORDS"),
             "\\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line"))

    Rdtxt$arguments <- if(length(s))
        c("\\arguments{",
          paste0("  \\item{", arg.n, "}{",
                 " ~~Describe \\code{", arg.n, "} here~~ }"),
          "}")
    else
        NULL

    if(is.na(filename)) return(Rdtxt)

    cat(unlist(Rdtxt), file = filename, sep = "\n")
    cat(strwrap(c(paste("Created file named ", sQuote(filename), ".", sep=""),
                  paste("Edit the file and move it to the appropriate",
                        "directory."))),
        sep = "\n")

    invisible(filename)
}

prompt.data.frame <-
function(object, filename = NULL, name = NULL, ...)
{
    paste0 <- function(...) paste(..., sep = "")

    if(missing(name))
        name <-
            if(is.character(object))
                object
            else {
                name <- substitute(object)
                if(is.language(name) && !is.name(name))
                    name <- eval(name)
                as.character(name)
            }
    if(is.null(filename))
        filename <- paste0(name, ".Rd")

    x <- get(name, envir = parent.frame())

    ## <FIXME>
    ## Always assume data set ???
    promptData(x, filename = filename, name = name)
    ## </FIXME>
}

promptData <-
function(object, filename = NULL, name = NULL)
{
    paste0 <- function(...) paste(..., sep = "")

    if(missing(name))
        name <-
            if(is.character(object))
                object
            else {
                name <- substitute(object)
                if(is.language(name) && !is.name(name))
                    name <- eval(name)
                as.character(name)
            }
    if(is.null(filename))
        filename <- paste0(name, ".Rd")

    ## Better than get(); works when called in fun :
    x <- get(name, envir = parent.frame())

    ## Construct the format.
    if(is.data.frame(x)) {
        fmt <- c("\\format{",
                 paste("  A data frame with",
                       nrow(x),
                       "observations on the following",
                       ifelse(ncol(x) == 1,
                              "variable.",
                              paste(ncol(x), "variables."))),
                 "  \\describe{")
        for(i in names(x)) {
            xi <- x[[i]]
            fmt <-
                c(fmt,
                  paste0("    \\item{", i, "}{",
                         if(inherits(xi, "ordered")) {
                             paste("an", data.class(xi),
                                   "factor with levels",
                                   paste0("\\code{", levels(xi), "}",
                                          collapse = " < "),
                                   collapse = " ")
                         } else if(inherits(xi, "factor")) {
                             paste("a factor with levels",
                                   paste0("\\code{", levels(xi), "}",
                                          collapse = " "),
                                   collapse = " ")
                         } else if(is.vector(xi)) {
                             paste("a", data.class(xi), "vector")
                         } else if(is.matrix(xi)) {
                             paste("a matrix with", ncol(xi), "columns")
                         } else {
                             paste("a", data.class(xi))
                         },
                         "}"))
        }
        fmt <- c(fmt, "  }", "}")
    }
    else {
        tf <- tempfile(); on.exit(unlink(tf))
        sink(tf) ; str(object) ; sink()
        fmt <- c("\\format{",
                 "  The format is:",
                 scan(tf, "", quiet = !getOption("verbose"), sep = "\n"),
                 "}")
    }

    Rdtxt <-
        list(name = paste0("\\name{", name, "}"),
             aliases = paste0("\\alias{", name, "}"),
             docType = "\\docType{data}",
             title = "\\title{ ~~ data name/kind ... ~~}",
             description = c("\\description{",
             "  ~~ A concise (1-5 lines) description of the dataset. ~~",
             "}"),
             usage = paste0("\\usage{data(", name, ")}"),
             format = fmt,
             details = c("\\details{",
             paste("  ~~ If necessary, more details than the",
                   "__description__ above ~~"),
             "}"),
             source = c("\\source{",
             paste("  ~~ reference to a publication or URL",
                   "from which the data were obtained ~~"),
             "}"),
             references = c("\\references{",
             "  ~~ possibly secondary sources and usages ~~",
             "}"),
             examples = c("\\examples{",
             paste0("data(", name, ")"),
             paste0("## maybe str(", name, ") ; plot(", name, ") ..."),
             "}"),
             keywords = "\\keyword{datasets}")

    if(is.na(filename)) return(Rdtxt)

    cat(unlist(Rdtxt), file = filename, sep = "\n")
    cat(strwrap(c(paste("Created file named ", sQuote(filename), ".", sep=""),
                  paste("Edit the file and move it to the appropriate",
                        "directory."))),
        sep = "\n")

    invisible(filename)
}
"?" <- function(e1, e2)
{
    e1Expr <- substitute(e1)
    if(missing(e2)) {
        if(is.call(e1Expr))
            return(.helpForCall(e1Expr, parent.frame()))
        if(is.name(e1Expr))
            e1 <- as.character(e1Expr)
        eval(substitute(help(TOPIC), list(TOPIC = e1)))
    }
  else {
      ## interpret e1 as a type, but to allow customization, do NOT force
      ## arbitrary expressions to be single character strings (so that methods
      ## can be defined for topicName).
        if(is.name(e1Expr))
            e1 <- as.character(e1Expr)
      e2Expr <- substitute(e2)
    if(is.name(e2Expr))
      e2 <- as.character(e2Expr)
        else if(is.call(e2Expr) && identical(e1, "method"))
            return(.helpForCall(e2Expr, parent.frame(), FALSE))
    topic <- topicName(e1, e2)
    doHelp <- .tryHelp(topic)
    if(inherits(doHelp, "try-error")) {
        stop(paste("no documentation of type \"", e1,
                   "\" and topic \"", e2,
                   "\" (or error in processing help)", sep=""))
    }
  }
}

topicName <- function(type, topic) {
    if((length(type) == 0) || (length(topic) == 0))
        character(0)
    else
        paste(paste(topic, collapse = ","), type, sep = "-")
}

.helpForCall <- function(expr, envir, doEval = TRUE) {
    f <- expr[[1]] # the function specifier
    where <- topenv(envir) # typically .GlobalEnv
    if(is.name(f))
        f <- as.character(f)
    if(!.isMethodsDispatchOn() || !isGeneric(f, where = where)){
        if(!is.character(f) || length(f) != 1)
            stop("The object of class \"", class(f), "\" in the function call \"",
                 deparse(expr), "\"could not be used as a documentation topic")
        h <- .tryHelp(f)
        if(inherits(h, "try-error"))
            stop("No methods for \"", f, "\" and no documentation for it as a function")
    }
    else {
        ## allow generic function objects or names
        if(is(f, "genericFunction")) {
            fdef <- f
            f <- fdef@generic
        }
        else
            fdef <- getGeneric(f, where = where)
        call <- match.call(fdef, expr)
        ## make the signature
        sigNames <- fdef@signature
        sigClasses <- rep.int("missing", length(sigNames))
        names(sigClasses) <- sigNames
        for(arg in sigNames) {
            argExpr <- elNamed(call, arg)
            if(!is.null(argExpr)) {
                simple <- (is.character(argExpr) || is.name(argExpr))
                ## TODO:  ideally, if doEval is TRUE, we would like to create
                ## the same context used by applyClosure in eval.c, but then
                ## skip the actual evaluation of the body.  If we could create
                ## this environment then passing it to selectMethod is closer to
                ## the semantics of the "real" function call than the code below.
                ## But, seems to need a change to eval.c and a flag to the evaluator.
                if(doEval || !simple) {
                    argVal <- try(eval(argExpr, envir))
                    if(is(argVal, "try-error"))
                        stop("Error in trying to evaluate the expression for argument \"",
                             arg, "\" (", deparse(argExpr), ")")
                    elNamed(sigClasses, arg) <- class(argVal)
                }
                else
                    elNamed(sigClasses, arg) <- as.character(argExpr)
            }
        }
        method <- selectMethod(f, sigClasses, optional=TRUE, fdef = fdef)
        if(is(method, "MethodDefinition"))
            sigClasses <- method@defined
        else
            warning("No method defined for function \"", f,
                    "\" and signature ",
                    paste(sigNames, " = \"", sigClasses, "\"", sep = "", collapse = ", "))
        topic <- topicName("method", c(f,sigClasses))
        h <- .tryHelp(topic)
        if(is(h, "try-error"))
            stop("No documentation for function \"", f,
                 "\" and signature ",
                 paste(sigNames, " = \"", sigClasses, "\"", sep = "", collapse = ", "))
    }
}

.tryHelp <- function(topic) {
    opts <- options(error= function()TRUE, show.error.messages = FALSE)
    on.exit(options(opts))
    try(do.call("help", list(topic)))
}

read.fwf <-
function(file, widths, header = FALSE, sep = "\t", as.is = FALSE,
         skip = 0, row.names, col.names, n = -1, ...)
{
    doone <- function(x) {
        x <- substring(x, first, last)
        x[nchar(x)==0] <- as.character(NA)
        x
    }
    FILE <- tempfile("Rfwf.")
    on.exit(unlink(FILE))
    raw <- readLines(file, n=n)
    st <- c(1, 1+cumsum(widths))
    first <- st[-length(st)]
    last <- cumsum(widths)
    cat(file = FILE, sapply(raw, doone),
        sep = c(rep(sep, length.out = length(widths)-1), "\n"))
    read.table(file = FILE, header = header, sep = sep, as.is = as.is,
	       skip = skip, row.names = row.names, col.names =
               col.names, quote="", ...)
}
url.show <-
    function (url,  title = url, file = tempfile(),
              delete.file = TRUE, method, ...)
{
    if (download.file(url, dest = file, method = method) != 0)
        stop("transfer failure")
    file.show(file, delete.file = delete.file, title = title, ...)
}
print.socket <- function(x, ...)
{
    if(length(as.integer(x$socket)) != 1)
	stop("invalid `socket' argument")
    cat("Socket connection #", x$socket, "to", x$host,
	"on port", x$port, "\n")
    invisible(x)
}

make.socket <- function(host = "localhost", port, fail = TRUE, server = FALSE)
{
    if(length(port <- as.integer(port)) != 1)
	stop("`port' must be integer of length 1")
    if(length(host <- as.character(host)) != 1)
	stop("`host' must be character of length 1")
    if (!server){
	tmp2 <- .C("Rsockconnect",
                   port = port,
                   host = host,
                   PACKAGE = "base")
    }
    else{
	if (host != "localhost")
	    stop("Can only receive calls on local machine")
	tmp <- .C("Rsockopen", port = port, PACKAGE="base")
	buffer <- paste(rep.int("#",256), collapse = "")
	tmp2 <- .C("Rsocklisten", port = tmp$port,
                   buffer = buffer, len = as.integer(256), PACKAGE="base")
	host <- substr(tmp2$buffer, 1, tmp2$len)
	.C("Rsockclose", tmp$port, PACKAGE="base")
    }
    if (tmp2$port <= 0) {
	w <- "Socket not established"
	if (fail) stop(w) else warning(w)
    }
    rval <- list(socket = tmp2$port, host = host, port = port)
    class(rval) <- "socket"
    rval
}

close.socket <- function(socket, ...)
{
    if(length(port <- as.integer(socket$socket)) != 1)
	stop("invalid `socket' argument")
    as.logical(.C("Rsockclose", port, PACKAGE="base")[[1]])
}

read.socket <- function(socket, maxlen=256, loop=FALSE)
{
    if(length(port <- as.integer(socket$socket)) != 1)
	stop("invalid `socket' argument")
    maxlen <- as.integer(maxlen)
    buffer <- paste(rep.int("#",maxlen), collapse="")
    repeat {
	tmp <- .C("Rsockread", port,
		  buffer = buffer, len = maxlen, PACKAGE="base")
	rval <- substr(tmp$buffer, 1, tmp$len)
	if (nchar(rval) > 0 || !loop) break
    }
    rval
}

write.socket <- function(socket, string)
{
    if(length(port <- as.integer(socket$socket)) != 1)
	stop("invalid `socket' argument")
    strlen <- length(strsplit(string,NULL)[[1]])
    invisible(.C("Rsockwrite", port, string,
		 as.integer(0), strlen, strlen, PACKAGE="base")[[5]])
}


####------ str : show STRucture of an R object
str <- function(object, ...) UseMethod("str")

str.data.frame <- function(object, ...)
{
    ## Method to 'str' for  'data.frame' objects
    if(! is.data.frame(object)) {
	warning("str.data.frame(.) called with non-data.frame. Coercing one.")
	object <- data.frame(object)
    }

    ## Show further classes // Assume that they do NOT have an own Method --
    ## not quite perfect ! (.Class = 'remaining classes', starting with current)
    cl <- oldClass(object); cl <- cl[cl != "data.frame"]  #- not THIS class
    if(0 < length(cl)) cat("Classes", cl, " and ")

    cat("`data.frame':	", nrow(object), " obs. of  ",
	(p <- length(object)), " variable", if(p != 1)"s", if(p > 0)":",
	"\n",sep="")

    ## calling next method, usually  str.default:
    if(length(l <- list(...)) && any("give.length" == names(l)))
	invisible(NextMethod("str", ...))
    else invisible(NextMethod("str", give.length=FALSE,...))
}

str.default <-
    function(object, max.level = 0, vec.len = 4, digits.d = 3,
	     nchar.max = 128, give.attr = TRUE, give.length = TRUE,
	     wid = getOption("width"), nest.lev = 0,
	     indent.str = paste(rep.int(" ", max(0, nest.lev + 1)), collapse = ".."),
	     ...)
{
    ## Purpose: Display STRucture of any R - object (in a compact form).
    ## --- see HELP file --
    ## ------------------------------------------------------------------------
    ## Author: Martin Maechler <maechler@stat.math.ethz.ch>	1990--1997
    ## ------ Please send Bug-reports, -fixes and improvements !
    ## ------------------------------------------------------------------------

    oo <- options(digits = digits.d); on.exit(options(oo))
    le <- length(object)
    P0 <- function(...) paste(..., sep="")
    pasteCh <- function(x)
	sapply(x, function(a) if(is.na(a)) "NA" else P0('"',a,'"'),
	       USE.NAMES = FALSE)
    ## le.str: not used for arrays:
    le.str <-
	if(is.na(le)) " __no length(.)__ "
	else if(give.length) {
	    if(le > 0) P0("[1:", paste(le), "]") else "(0)"
	} else ""
    v.len <- vec.len # modify v.len, not vec.len!
    ## NON interesting attributes:
    std.attr <- "names"

    has.class <- !is.null(cl <- attr(object, "class"))
    mod <- ""; char.like <- FALSE
    if(give.attr) a <- attributes(object)#-- save for later...

    if(is.function(object)) {
	cat(if(is.null(ao <- args(object))) deparse(object)
	else { dp <- deparse(ao); paste(dp[-length(dp)], collapse="\n") },"\n")
    } else if (is.null(object))
	cat(" NULL\n")
    else if(is.list(object)) {
	i.pl <- is.pairlist(object)
	is.d.f <- is.data.frame(object)
	if(is.d.f) std.attr <- c(std.attr, "class", if(is.d.f) "row.names")
	if(le == 0) {
	    if(!is.d.f) cat(" ", if(i.pl)"pair", "list()\n",sep="")
	} else {
	    if(has.class && any(sapply(paste("str", cl, sep="."),
					#use sys.function(.) ..
					function(ob)exists(ob, mode= "function",
							   inherits= TRUE)))) {
		## str.default is a 'NextMethod' : omit the 'List of ..'
		std.attr <- c(std.attr, "class", if(is.d.f) "row.names")
	    } else {
		cat(if(i.pl) "Dotted pair list" else "List",
		    " of ", le, "\n", sep="")
	    }
	    if (max.level==0 || nest.lev < max.level) {
		nam.ob <-
		    if(is.null(nam.ob <- names(object))) rep.int("", le)
		    else { max.ncnam <- max(nchar(nam.ob))
			   format.char(nam.ob, width = max.ncnam, flag = '-')
		       }
		for(i in 1:le) {
		    cat(indent.str,"$ ", nam.ob[i], ":", sep="")
		    str(object[[i]], nest.lev = nest.lev + 1,
			indent.str= paste(indent.str,".."), nchar.max=nchar.max,
			max.level=max.level, vec.len=vec.len, digits.d=digits.d,
			give.attr= give.attr, give.length= give.length, wid=wid)
		}
	    }
	}
    } else { #- not function, not list
	if(is.vector(object)
	   || (is.array(object) && is.atomic(object))
	   || is.vector(object, mode='language')
	   || is.vector(object, mode='symbol')## R bug(<=0.50-a4) should be part
	   ) { ##-- Splus: FALSE for 'named vectors'
	    if(is.atomic(object)) {
		##-- atomic:   numeric	complex	 character  logical
		mod <- substr(mode(object), 1, 4)
		if     (mod == "nume")
		    mod <- if(is.integer(object)) "int"
		    else if(has.class) cl[1] else "num"
		else if(mod == "char") { mod <- "chr"; char.like <- TRUE }
		else if(mod == "comp") mod <- "cplx" #- else: keep 'logi'
		if(is.array(object)) {
		    di <- dim(object)
		    di <- P0(ifelse(di>1, "1:",""), di,
			     ifelse(di>0, "" ," "))
		    le.str <- paste(c("[", P0(di[-length(di)], ", "),
				      di[length(di)], "]"), collapse = "")
		    std.attr <- "dim" #- "names"
		} else if(!is.null(names(object))) {
		    mod <- paste("Named", mod)
		    std.attr <- std.attr[std.attr != "names"]
		}
		str1 <-
		    if(le == 1 && !is.array(object)) paste(NULL, mod)
		    else P0(" ", mod, if(le>0)" ", le.str)
	    } else { ##-- not atomic, but vector: #
		mod <- typeof(object)#-- typeof(.) is more precise than mode!
		str1 <- switch(mod,
			       call = " call",
			       language = " language",
			       symbol = " symbol",
			       expression = " ",# "expression(..)" by deparse(.)
			       name = " name",
			       ##not in R:argument = "",# .Argument(.) by deparse(.)
			       ## in R (once):	comment.expression

			       ## default :
			       paste("		#>#>", mod, NULL)
			       )
	    }
#  These are S-PLUS classes not found in R.
# 	} else if (inherits(object,"rts") || inherits(object,"cts")
# 		   || inherits(object,"its")) {
# 	    tsp.a <- tspar(object)
# 	    t.cl <- cl[b.ts <- substring(cl,2,3) == "ts"] # "rts" "cts" or "its"
# 	    ts.kind <- switch(t.cl,
# 			      rts="Regular", cts="Calendar", its="Irregular")
# 	    ## from  print.summary.ts(.) :
# 	    pars <- unlist(sapply(summary(object)$ pars, format,
# 				  nsmall=0, digits=digits.d, justify = "none"))
# 	    if(length(pars)>=4) pars <- pars[-3]
# 	    pars <- paste(abbreviate(names(pars),min=2), pars,
# 			  sep= "=", collapse=", ")
# 	    str1 <- P0(ts.kind, " Time-Series ", le.str, " ", pars, ":")
# 	    v.len <- switch(t.cl,rts=.8, cts=.6, its=.9) * v.len
# 	    class(object) <- if(any(!b.ts)) cl[!b.ts]
# 	    std.attr <- c(std.attr, "tspar")
	} else if(stats::is.ts(object)) {
	    tsp.a <- stats::tsp(object)
	    str1 <- P0(" Time-Series ", le.str, " from ", format(tsp.a[1]),
		       " to ", format(tsp.a[2]), ":")
	    std.attr <- c("tsp","class") #- "names"
	} else if (is.factor(object)) {
	    nl <- length(lev.att <- levels(object))
	    if(!is.character(lev.att)) {# should not happen..
		warning("`object' doesn't have legal levels()!")
		nl <- 0
	    }
	    ord <- is.ordered(object)
	    object <- unclass(object)
	    if(nl) {
		lenl <- cumsum(3 + nchar(lev.att))# level space
		ml <- if(nl <= 1 || lenl[nl] <= 13)
		    nl else which(lenl > 13)[1]
		if((d <- lenl[ml] - if(ml>1)18 else 14) >= 3)# truncate last
		    lev.att[ml] <-
			P0(substring(lev.att[ml],1, nchar(lev.att[ml])-d), "..")
	    }
	    else # nl == 0
		ml <- length(lev.att <- "")

	    lsep <- if(ord) "<" else ","
	    str1 <- P0(if(ord)" Ord.f" else " F",
		       "actor w/ ", nl, " level",if(nl != 1) "s",
		       if(nl) " ",
		       if(nl) P0(pasteCh(lev.att[1:ml]), collapse = lsep),
		       if(ml < nl) P0(lsep,".."), ":")

	    std.attr <- c("levels","class")
	} else if(has.class) {
	    cat("Class", if(length(cl) > 1) "es",
		" '", paste(cl, collapse = "', '"), "' ", sep="")
	    ## If there's a str.<method>, it should have been called before!
	    str(unclass(object),
		max.level = max.level, vec.len = vec.len, digits.d = digits.d,
		indent.str = paste(indent.str,".."), nest.lev = nest.lev + 1,
		nchar.max = nchar.max, give.attr = give.attr, wid=wid)
	    return(invisible())
	} else if(is.atomic(object)) {
	    if((1 == length(a <- attributes(object))) && (names(a) == "names"))
		str1 <- paste(" Named vector", le.str)
	    else {
		##-- atomic / not-vector  "unclassified object" ---
		str1 <- paste(" atomic", le.str)
	    }
	} else {
	    ##-- NOT-atomic / not-vector  "unclassified object" ---
	    ##str1 <- paste(" ??? of length", le, ":")
	    str1 <- paste("length", le)
	}
	##-- end  if else..if else...  {still non-list case}

	##-- This needs some improvement: Not list nor atomic --
	if ((is.language(object) || !is.atomic(object)) && !has.class) {
	    ##-- has.class superfluous --
	    mod <- mode(object)
	    give.mode <- FALSE
	    if (any(mod == c("call", "language", "(", "symbol",
                    "externalptr", "weakref")) || is.environment(object)) {
		##give.mode <- !is.vector(object)#--then it has not yet been done
		object <- deparse(object)
                if(mod == "(") give.mode <- TRUE
		le <- length(object) #== 1, always / depending on char.length ?
		format.fun <- function(x)x
		v.len <- round(.5 * v.len)
	    } else if (mod == "expression") {
		format.fun <- function(x) deparse(as.expression(x))
		v.len <- round(.75 * v.len)
	    } else if (mod == "name"){
		object <- paste(object)#-- show `as' char
	    } else if (mod == "argument"){
		format.fun <- deparse
	    } else {
		give.mode <- TRUE
	    }
	    if(give.mode) str1 <- P0(str1, ', mode "', mod,'":')

	} else if(is.logical(object)) {
	    v.len <- 3 * v.len
	    format.fun <- format
	} else if(is.numeric(object)) {
	    iv.len <- round(2.5 * v.len)
	    if(iSurv <- inherits(object, "Surv"))
		std.attr <- c(std.attr, "class")
	    int.surv <- iSurv || is.integer(object)
	    if(!int.surv) {
		ob <- if(le > iv.len) object[seq(len=iv.len)] else object
		ao <- abs(ob <- ob[!is.na(ob)])
	    }
	    if(int.surv || (all(ao > 1e-10 | ao==0) && all(ao < 1e10| ao==0) &&
			    all(ob == signif(ob, digits.d)))) {
		v.len <- iv.len
		format.fun <- function(x)x
	    } else {
		v.len <- round(1.25 * v.len)
		format.fun <- format
	    }
	} else if(is.complex(object)) {
	    v.len <- round(.75 * v.len)
	    format.fun <- format
	}

	## Not sure, this is ever triggered:
	if(is.na(le)) { warning("'str.default': 'le' is NA !!"); le <- 0}

	if(char.like) {
	    v.len <-
		if(missing(vec.len))
		    max(1,sum(cumsum(3 + if(le>0) nchar(object) else 0) <
			      wid - (4 + 5*nest.lev + nchar(str1))))
	    ## `5*ne..' above is fudge factor
		else round(v.len)
	    ile <- min(le, v.len)
	    if(ile >= 1) { # have LONG char ?!
		nc <- nchar(object[1:ile])
		if(any((ii <- nc > nchar.max)))
		    object[ii] <- P0(substr(object[ii], 1, nchar.max),
				     "| __truncated__")
	    }
	    formObj <- function(x) P0(pasteCh(x), collapse=" ")
	}
	else {
	    if(!exists("format.fun", inherits=TRUE)) #-- define one --
		format.fun <-
		    if(mod == 'num' || mod == 'cplx') format else as.character
	    ## v.len <- max(1,round(v.len))
	    ile <- min(v.len, le)
	    formObj <- function(x) paste(format.fun(x), collapse = " ")
	}

	cat(str1, " ", formObj(if(ile >= 1) object[1:ile] else
			       if(v.len > 0) object),
	    if(le > v.len) " ...", "\n", sep="")

    } ## else (not function nor list)----------------------------------------

    if(give.attr) { ## possible: || has.class && any(cl == 'terms')
	nam <- names(a)
	for (i in seq(len=length(a)))
	    if (all(nam[i] != std.attr)) {# only `non-standard' attributes:
		cat(indent.str, P0('- attr(*, "',nam[i],'")='),sep="")
		str(a[[i]],
		    indent.str= paste(indent.str,".."), nest.lev= nest.lev+1,
		    max.level = max.level, digits.d = digits.d,
		    nchar.max = nchar.max,
		    vec.len = if(nam[i] == "source") 1 else vec.len,
		    give.attr= give.attr, give.length= give.length, wid= wid)
	    }
    }
    invisible()	 ## invisible(object)#-- is SLOOOOW on large objects
}# end of `str.default()'

## An extended `ls()' using str() :
ls.str <- function(pos = 1, pattern, ..., envir = as.environment(pos),
		   mode = "any", max.level = 1, give.attr = FALSE)
{
    n <- length(nms <- ls(..., envir = envir, pattern = pattern))
    r <- character(n)
    for(i in seq(length = n))
	if(exists(nam <- nms[i], envir = envir, mode = mode)) {
	    cat(nam, ": ")
	    r[i] <- nam
	    str(get(nam, envir = envir, mode = mode),
		max.level = max.level, give.attr = give.attr)
	}
    invisible(r)
}

lsf.str <- function(pos = 1, ..., envir = as.environment(pos))
    ls.str(pos = pos, envir = envir, mode = "function", ...)
summaryRprof <- function(filename = "Rprof.out", chunksize = 5000)
{
    rprof <- file(filename)
    open(rprof, "r")
    on.exit(close(rprof))
    head  <-  scan(rprof,  nlines = 1, what = list("", interval=0), sep = "=",
                   quiet = TRUE)

    total <- new.env(hash = TRUE)
    self <- new.env(hash = TRUE)
    inc <- function(f, e){
        if (exists(f, envir = e, inherits = FALSE))
            assign(f, get(f, envir = e)+1, envir = e)
        else
            assign(f, 1, envir = e)
    }
    count <- 0
    repeat({
        chunk <- readLines(rprof, n = chunksize)
        nread <- length(chunk)
        if (nread == 0)
            break
        count <- count+nread
        thelines <- strsplit(chunk, " ", fixed=TRUE)
        lapply(thelines, function (a.line){
            lapply(unique(a.line), inc, e = total)
            inc(a.line[[1]], e = self)
        })
        if (nread < chunksize)
            break
    })
    if(count == 0) stop("no events were recorded")
    totalt <- sapply(ls(envir = total), function(f) get(f, envir = total))
    selft <- sapply(ls(envir = self), function(f) get(f, envir = self))

    digits <- ifelse(head$interval < 1e4, 3, 2)
    totalpct <- round(totalt*100/count, 1)
    selfpct <- round(selft*100/sum(selft), 1)
    totalt <- round(totalt*head$interval/1e6, digits)
    selft <- round(selft*head$interval/1e6, digits)

    combine <- merge(data.frame(self.time = selft, self.pct = selfpct),
                     data.frame(total.time = totalt, total.pct = totalpct),
                     by = 0, all = TRUE)
    row.names(combine) <- combine[, "Row.names"]
    combine <- combine[, -1]
    combine$self.time[is.na(combine$self.time)] <- 0
    combine$self.pct[is.na(combine$self.pct)] <- 0
    list(by.self = combine[order(-combine$self.time), ],
         by.total = combine[order(-combine$total.time), c(3,4,1,2)],
         sampling.time = count * head$interval/1e6)
}

Rprof <- function(filename = "Rprof.out", append = FALSE, interval = 0.02)
{
    if(is.null(filename)) filename <- ""
    invisible(.Internal(Rprof(filename, append, interval)))
}

bug.report <- function(subject = "", ccaddress = Sys.getenv("USER"),
                       method = getOption("mailer"),
                       address = "r-bugs@r-project.org",
                       file = "R.bug.report")
{
    methods <- c("mailx", "gnudoit", "none", "ess")

    method <-
	if(is.null(method)) "none"
	else methods[pmatch(method, methods)]

    body <- paste("\\n<<insert bug report here>>\\n\\n\\n\\n",
		  "--please do not edit the information below--\\n\\n",
		  "Version:\\n ",
		  paste(names(R.version),R.version, sep=" = ",collapse="\\n "),
		  "\\n\\n",
		  "Search Path:\\n ",
		  paste(search(), collapse=", "),
		  "\\n", sep="", collapse="")

    if(method == "gnudoit") {
	cmd <- paste("gnudoit -q '",
		     "(mail nil \"", address, "\")",
		     "(insert \"", body, "\")",
		     "(search-backward \"Subject:\")",
		     "(end-of-line)'",
		     sep="")
	system(cmd)
    }
    else if(method=="none"){

        disclaimer <-
            paste("# Your mailer is set to \"none\" (default on Windows),\n",
                  "# hence we cannot send the bug report directly from R.\n",
                  "# Please copy the bug report (after finishing it) to\n",
                  "# your favorite email program and send it to\n#\n",
                  "#       ", address, "\n#\n",
                  "######################################################\n",
                  "\n\n", sep = "")


        cat(disclaimer, file=file)
	body <- gsub("\\\\n", "\n", body)
	cat(body, file=file, append=TRUE)
	system(paste(getOption("editor"), file))
        cat("The unsent bug report can be found in file", file, "\n")
    }
    else if(method == "mailx"){

        if(missing(subject))
            stop("Subject missing")

	body <- gsub("\\\\n", "\n", body)
	cat(body, file=file, append=FALSE)
	system(paste(getOption("editor"), file))

        if(is.character(ccaddress) && nchar(ccaddress)>0) {
            cmdargs <- paste("-s '", subject, "' -c", ccaddress,
                             address, "<", file, "2>/dev/null")
        }
        else
            cmdargs <- paste("-s '", subject, "'", address, "<",
                             file, "2>/dev/null")

        status <- 1

        cat("Submit the bug report? ")
        answer <- readline()
        answer <- grep("y", answer, ignore.case=TRUE)
        if(length(answer)>0){
            cat("Sending email ...\n")
            status <- system(paste("mailx", cmdargs))
            if(status > 0)
                status <- system(paste("Mail", cmdargs))
            if(status > 0)
                status <- system(paste("/usr/ucb/mail", cmdargs))

            if(status==0) unlink(file)
            else{
                cat("Sending email failed!\n")
                cat("The unsent bug report can be found in file",
                    file, "\n")
            }

        }
        else
            cat("The unsent bug report can be found in file",
                file, "\n")

    }
    else if(method=="ess"){
	body <- gsub("\\\\n", "\n", body)
	cat(body)
    }
}
download.file <- function(url, destfile, method,
                          quiet = FALSE, mode = "w", cacheOK = TRUE)
{
    method <- if (missing(method))
        ifelse(!is.null(getOption("download.file.method")),
               getOption("download.file.method"),
               "auto")
    else
        match.arg(method, c("auto", "internal", "wget", "lynx"))

    if(method == "auto") {
        if(capabilities("http/ftp"))
            method <- "internal"
        else if(length(grep("^file:", url)))
            method <- "internal"
        else if(system("wget --help > /dev/null")==0)
            method <- "wget"
        else if(system("lynx -help > /dev/null")==0)
            method <- "lynx"
        else
            stop("No download method found")
    }
    if(method == "internal")
        status <- .Internal(download(url, destfile, quiet, mode, cacheOK))
    else if(method == "wget") {
        extra <- if(quiet) " --quiet" else ""
        if(!cacheOK) extra <- paste(extra, "--cache=off")
        status <- system(paste("wget", extra, " '", url,
                               "' -O", path.expand(destfile), sep=""))
    } else if(method == "lynx")
        status <- system(paste("lynx -dump '", url, "' >",
                               path.expand(destfile), sep=""))

    if(status > 0)
        warning("Download had nonzero exit status")

    invisible(status)
}

nsl <- function(hostname)
    .Internal(nsl(hostname))
### NOTE: This is for Unix only (cf. ../{mac,windows}/help.R)

help <- function(topic, offline = FALSE, package = .packages(),
                 lib.loc = NULL, verbose = getOption("verbose"),
                 try.all.packages = getOption("help.try.all.packages"),
                 htmlhelp = getOption("htmlhelp"),
                 pager = getOption("pager"))
{
    htmlhelp <- is.logical(htmlhelp) && htmlhelp
    if (!missing(package))
        if (is.name(y <- substitute(package)))
            package <- as.character(y)
    if (!missing(topic)) {
        ischar<-try(is.character(topic), silent=TRUE)
        if (inherits(ischar, "try-error")) ischar<-FALSE
        if (!ischar) topic <- deparse(substitute(topic))
        # for cmd/help ..
        if (!is.na(match(topic, c("+", "-", "*", "/", "^", "%%"))))
            topic <- "Arithmetic"
        else if (!is.na(match(topic, c("<", ">", "<=", ">=", "==", "!="))))
            topic <- "Comparison"
        else if (!is.na(match(topic, c("[", "[[", "$"))))
            topic <- "Extract"
        else if (!is.na(match(topic, c("&", "&&", "|", "||", "!"))))
            topic <- "Logic"
        else if (!is.na(match(topic, c("%*%"))))
            topic <- "matmult"
        type <- if(offline) "latex" else if (htmlhelp) "html" else "help"
        INDICES <- .find.package(package, lib.loc, verbose = verbose)
        file <- index.search(topic, INDICES, "AnIndex", type)
        if (length(file) && file != "") {
            if (verbose)
                cat("\t\t\t\t\t\tHelp file name ",
                    sQuote(paste(basename(file), ".Rd", sep = "")),
                    "\n", sep = "")
            if (!offline) {
                if (htmlhelp) {
                    if(file.exists(file)) {
                        ofile <- file
                        base.pos <- match("package:base", search())
                        ## We need to use the version in per-session dir
                        ## if we can.
                        lnkfile <-
                            file.path(tempdir(), ".R",
                                      "library", package, "html",
                                      paste(topic, "html", sep="."))
                        if (any(ex <- file.exists(lnkfile))) {
                            lnkfile <- lnkfile[ex]
                            file <- lnkfile[1] # could be more than one
                        }
                        if (file == ofile) {
                            warning("Using non-linked HTML file: style sheet and hyperlinks may be incorrect")
                        }
                        file <- paste("file://", file, sep = "")
                        if(is.null(browser <- getOption("browser")))
                            stop("options(\"browser\") not set")
                        browseURL(file)
                        cat("help() for",topic, " is shown in browser",browser,
                            "...\nUse\t help(",topic,", htmlhelp=FALSE)\nor\t",
                            "options(htmlhelp = FALSE)\nto revert.\n")
                        return(invisible())
                    } else {
                        if(verbose)
                            cat("no HTML help for", sQuote(topic),
                                "is available\n", sep = "")
                        file <- index.search(topic, INDICES, "AnIndex", "help")
                    }
                }
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                ## end of experimental code
                if(file.exists(zfile))
                    file.show(zfile,
                              title = paste("R Help on", sQuote(topic)),
                              delete.file = (zfile != file),
                              pager = pager)
                else
                    stop(paste("The help file for", sQuote(topic),
                               "is missing"))
                return(invisible())
            }
            else {
                ## experimental code
                zfile <- zip.file.extract(file, "Rhelp.zip")
                if(zfile != file) on.exit(unlink(zfile))
                ## end of experimental code
                if(file.exists(zfile)) {
                    FILE <- tempfile()
                    on.exit(unlink(FILE))
                    cat("\\documentclass[",
                        getOption("papersize"),
                        "paper]{article}",
                        "\n",
                        "\\usepackage[",
                        Sys.getenv("R_RD4DVI"),
                        "]{Rd}",
                        "\n",
                        "\\InputIfFileExists{Rhelp.cfg}{}{}\n",
                        "\\begin{document}\n",
                        file = FILE, sep = "")
                    file.append(FILE, zfile)
                    cat("\\end{document}\n",
                        file = FILE, append = TRUE)
                    ## <NOTE>
                    ## We now have help-print.sh in share/sh but we do
                    ## not use the .Script mechanism because we play
                    ## with the TEXINPUTS environment variable and not
                    ## all systems can be assumed to support Sys.putenv().
                    system(paste(paste("TEXINPUTS=",
                                       file.path(R.home(), "share",
                                                 "texmf"),
                                       ":",
                                       "$TEXINPUTS",
                                       sep = ""),
                                 "/bin/sh",
                                 file.path(R.home(), "share", "sh",
                                           "help-print.sh"),
                                 FILE,
                                 topic,
                                 getOption("latexcmd"),
                                 getOption("dvipscmd")))
                    ## </NOTE>
                    return(invisible())
                }
                else
                    stop(paste("No offline documentation for", topic,
                               "is available"))
            }
        }
        else {
            if(is.null(try.all.packages) || !is.logical(try.all.packages))
                try.all.packages <- FALSE
            if(try.all.packages && missing(package) && missing(lib.loc)) {
                ## try all the remaining packages
                lib.loc <- .libPaths()
                packages <- .packages(all.available = TRUE,
                                      lib.loc = lib.loc)
                packages <- packages[is.na(match(packages, .packages()))]
                pkgs <- libs <- character(0)
                for (lib in lib.loc)
                    for (pkg in packages) {
                        INDEX <- system.file(package = pkg, lib.loc = lib)
                        file <- index.search(topic, INDEX, "AnIndex", "help")
                        if(length(file) && file != "") {
                            pkgs <- c(pkgs, pkg)
                            libs <- c(libs, lib)
                        }
                    }
                if(length(pkgs) == 1) {
                    writeLines(c(paste("  topic", sQuote(topic),
                                       "is not in any loaded package"),
                                 paste("  but can be found in package",
                                       sQuote(pkgs), "in library",
                                       sQuote(libs))))
                } else if(length(pkgs) > 1) {
                    writeLines(c(paste("  topic", sQuote(topic),
                                       "is not in any loaded package"),
                                 paste("  but can be found in the",
                                       "following packages:")))
                    A <- cbind(package = pkgs, library = libs)
                    rownames(A) <- 1 : nrow(A)
                    print(A, quote = FALSE)
                } else {
                    stop(paste("No documentation for ", sQuote(topic),
                               " in specified packages and libraries:\n",
                               "  you could try ",
                               sQuote(paste("help.search(\"", topic,
                                            "\")", sep = "")),
                               sep = ""))

                }
            } else {
                    stop(paste("No documentation for ", sQuote(topic),
                               " in specified packages and libraries:\n",
                               "  you could try ",
                               sQuote(paste("help.search(\"", topic,
                                            "\")", sep = "")),
                               sep = ""))
            }
        }
    }
    else if (!missing(package))
        library(help = package, lib.loc = lib.loc, character.only = TRUE)
    else if (!missing(lib.loc))
        library(lib.loc = lib.loc)
    else help("help", package = "utils", lib.loc = .Library)
}
help.start <- function (gui = "irrelevant", browser = getOption("browser"),
			remote = NULL)
{
    if(is.null(browser))
	stop("Invalid browser name, check options(\"browser\").")
    if(browser != getOption("browser")) {
        msg <- paste("Changing the default browser",
                     "(as specified by the `browser' option)",
                     "to the given browser so that it gets used",
                     "for all future help requests.")
        writeLines(strwrap(msg, exdent = 4))
        options(browser = browser)
    }
#     sessiondir <- file.path(tempdir(), ".R")
#     dir.create(sessiondir)
#     dir.create(file.path(sessiondir, "doc"))
#     dir.create(file.path(sessiondir, "doc", "html"))
    cat("Making links in per-session dir ...\n")
    .Script("sh", "help-links.sh",
            paste(tempdir(), paste(.libPaths(), collapse = " ")))
    make.packages.html()
    tmpdir <- paste("file://", tempdir(), "/.R", sep = "")
    url <- paste(if (is.null(remote)) tmpdir else remote,
		 "/doc/html/index.html", sep = "")
    writeLines(strwrap(paste("If", browser, "is already running,",
                             "it is *not* restarted, and you must",
                             "switch to its window."),
                       exdent = 4))
    writeLines("Otherwise, be patient ...")
    browseURL(url)
    options(htmlhelp = TRUE)
}

browseURL <- function(url, browser = getOption("browser"))
{
    ## escape characters.  ' can occur in URLs, so we must use " to
    ## delimit the URL.  We need to escape $, but "`\ do not occur in
    ## valid URLs (RFC 2396, on the W2C site).
    shQuote <- function(string)
        paste('"', gsub("\\$", "\\\\$", string), '"', sep="")

    if(!is.character(url) || !(length(url) == 1) || (nchar(url) == 0))
        stop("url must be a non-empty character string")
    if(!is.character(browser)
       || !(length(browser) == 1)
       || (nchar(browser) == 0))
        stop("browser must be a non-empty character string")

    if (.Platform$GUI=="AQUA" ||
        length(grep("^(localhost|):", Sys.getenv("DISPLAY"))) > 0)
      isLocal <- TRUE
    else
      isLocal <- FALSE

    quotedUrl <- shQuote(url)
    remoteCmd <- if(isLocal)
        switch(basename(browser),
               "gnome-moz-remote" =, "open" = quotedUrl,
               "galeon" = paste("-x", quotedUrl),
               "kfmclient" = paste("openURL", quotedUrl),
               "netscape" =, "mozilla" =, "opera" =, "firefox" = {
                   paste("-remote \"openURL(",
                         ## Quote ',' and ')' ...
                         gsub("([,)$])", "%\\1", url), ")\"",
                         sep = "")
               }, quotedUrl)
    else quotedUrl
    system(paste(browser, remoteCmd, "2>&1 >/dev/null ||",
                 browser, quotedUrl, "&"))
}

make.packages.html <- function(lib.loc=.libPaths())
{
    f.tg <- file.path(tempdir(), ".R/doc/html/packages.html")
    if(!file.create(f.tg)) {
        warning("cannot create HTML package index")
        return(FALSE)
    }
    searchindex <- file.path(tempdir(), ".R/doc/html/search/index.txt")
    if(!file.create(searchindex)) {
        warning("cannot create HTML search index")
        return(FALSE)
    }
    file.append(f.tg, file.path(R.home(), "doc/html/packages-head.html"))
    out <- file(f.tg, open="a")
    search <- file(searchindex, open="w")
    known <- character(0)
    for (lib in lib.loc) {
        cat("<p><h3>Packages in ", lib, '</h3>\n<p><table width="100%">\n',
            sep = "", file=out)
        pg <- sort(.packages(all.available = TRUE, lib.loc = lib))
        for (i in pg) {
            ## links are set up to break ties of package names
            before <- sum(i %in% known)
            link <- if(before == 0) i else paste(i, before, sep=".")
            from <- file.path(lib, i)
            to <- file.path(tempdir(), ".R", "library", link)
            file.symlink(from, to)
            title <- packageDescription(i, lib.loc = lib, field="Title")
            if (is.na(title)) title <- "-- Title is missing --"
            cat('<tr align="left" valign="top">\n',
                '<td width="25%"><a href="../../library/', link,
                '/html/00Index.html">', i, "</a></td><td>", title,
                "</td></tr>\n", file=out, sep="")
            contentsfile <- file.path(from, "CONTENTS")
            if(!file.exists(contentsfile)) next
            contents <- readLines(contentsfile)
            contents <- gsub(paste("/library/", i, sep = ""),
                             paste("/library/", link, sep = ""),
                             contents)
            writeLines(contents, search)
        }
        cat("</table>\n\n", file=out)
        known <- c(known, pg)
    }
    cat("</body></html>\n", file=out)
    close(out)
    close(search)
    invisible(TRUE)
}
install.packages <- function(pkgs, lib, CRAN=getOption("CRAN"),
                             contriburl=contrib.url(CRAN),
                             method, available=NULL, destdir=NULL,
			     installWithVers=FALSE)
{
    if(missing(lib) || is.null(lib)) {
        lib <- .libPaths()[1]
        if(length(.libPaths()) > 1)
            warning(paste("argument `lib' is missing: using", lib))
    }
    localcran <- length(grep("^file:", contriburl)) > 0
    if(!localcran) {
        if (is.null(destdir)){
            tmpd <- tempfile("Rinstdir")
            if (!dir.create(tmpd))
                stop('Unable to create temp directory ', tmpd)
        } else tmpd <- destdir
    }

    foundpkgs <- download.packages(pkgs, destdir=tmpd,
                                   available=available,
                                   contriburl=contriburl, method=method)

    if(!is.null(foundpkgs))
    {
        update <- cbind(pkgs, lib)
        colnames(update) <- c("Package", "LibPath")
        for(lib in unique(update[,"LibPath"]))
        {
            oklib <- lib==update[,"LibPath"]
            for(p in update[oklib, "Package"])
            {
                okp <- p == foundpkgs[, 1]
                if(length(okp) > 0){
                    cmd <- paste(file.path(R.home(),"bin","R"),
				 "CMD INSTALL")
		    if (installWithVers)
			cmd <- paste(cmd,"--with-package-versions")

		    cmd <- paste(cmd,"-l",lib,foundpkgs[okp, 2])
                    status <- system(cmd)
                    if(status > 0){
                        warning(paste("Installation of package",
                                      foundpkgs[okp, 1],
                                      "had non-zero exit status"))
                    }
                }
            }
        }
        cat("\n")
        if(!localcran && is.null(destdir)){
            answer <- substr(readline("Delete downloaded files (y/N)? "), 1, 1)
            if(answer == "y" | answer == "Y")
                unlink(tmpd, TRUE)
            else
                cat("The packages are in", tmpd)
            cat("\n")
        }
    }
    else
        unlink(tmpd, TRUE)
    invisible()
}


download.packages <- function(pkgs, destdir, available=NULL,
                              CRAN=getOption("CRAN"),
                              contriburl=contrib.url(CRAN),
                              method)
{
    dirTest <- function(x) !is.na(isdir <- file.info(x)$isdir) & isdir

    localcran <- length(grep("^file:", contriburl)) > 0
    if(!localcran && !dirTest(destdir)) stop("destdir is not a directory")
    if(is.null(available))
        available <- CRAN.packages(contriburl=contriburl, method=method)

    retval <- NULL
    for(p in unique(pkgs))
    {
        ok <- (available[,"Package"] == p) | (available[,"Bundle"] == p)
        ok <- ok & !is.na(ok)
        if(!any(ok))
            warning(paste("No package \"", p, "\" on CRAN.", sep=""))
        else{
            fn <- paste(p, "_", available[ok, "Version"], ".tar.gz", sep="")
            if(localcran){
                fn <- paste(substring(contriburl, 6), fn, sep="/")
                retval <- rbind(retval, c(p, fn))
            }
            else{
                url <- paste(contriburl, fn, sep="/")
                destfile <- file.path(destdir, fn)

                if(download.file(url, destfile, method) == 0)
                    retval <- rbind(retval, c(p, destfile))
                else
                    warning(paste("Download of package", p, "failed"))
            }
        }
    }

    retval
}

contrib.url <- function(CRAN, type=c("source","mac.binary")){
  type<-match.arg(type)
  switch(type,
         source=paste(CRAN,"/src/contrib",sep=""),
         mac.binary=paste(CRAN,"/bin/macosx/",version$major, ".", substr(version$minor,1,1),sep="")
         )
}
## <entry>
## Deprecated in 1.9.0
package.contents <- function(pkg, lib.loc=NULL)
{
    .Deprecated(package="utils")
    file <- system.file("CONTENTS", package = pkg, lib.loc = lib.loc)
    if(file == "") {
        warning(paste("Cannot find CONTENTS file of package", pkg))
        return(NA)
    }

    read.dcf(file=file, fields=c("Entry", "Keywords", "Description"))
}
## </entry>
shQuote <- function(string, type = c("sh", "csh", "cmd"))
{
    cshquote <- function(x) {
        xx <- strsplit(x, "'", fixed = TRUE)[[1]]
        paste(paste("'", xx, "'", sep = ""), collapse="\"'\"")
    }
    type <- match.arg(type)
    if(type == "cmd") {
        paste('"', gsub('"', '\\\\"', string), '"', sep = "")
    } else {
        if(!length(string)) return('')
        has_single_quote <- grep("'", string)
        if(!length(has_single_quote))
            return(paste("'", string, "'", sep = ""))
        if(type == "sh")
            paste('"', gsub('(["$`\\])', "\\\\\\1", string), '"', sep="")
        else {
            if(!length(grep('([$`])', string))) {
                paste('"', gsub('(["!\\])', "\\\\\\1", string), '"', sep="")
            } else sapply(string, cshquote)
        }
    }
}
vignette <-
function(topic, package = NULL, lib.loc = NULL)
{
    if(is.null(package))
        package <- .packages(all.available = TRUE, lib.loc)
    paths <- .find.package(package, lib.loc)

    ## Find the directories with a 'doc' subdirectory *possibly*
    ## containing vignettes.

    paths <- paths[tools::fileTest("-d", file.path(paths, "doc"))]

    vignettes <-
        lapply(paths, 
               function(dir) {
                   tools::listFilesWithType(file.path(dir, "doc"),
                                            "vignette")
               })

    if(!missing(topic)) {
        topic <- topic[1]               # Just making sure ...
        vignettes <- as.character(unlist(vignettes))
        idx <-
            which(tools::filePathSansExt(basename(vignettes)) == topic)
        if(length(idx)) {
            f <- sub("\\.[[:alpha:]]+$", ".pdf", vignettes[idx])
            f <- f[tools::fileTest("-f", f)]
            if(length(f) > 1) {
                ## <FIXME>
                ## Should really offer a menu to select from.
                f <- f[1]
                warning(paste("vignette ", sQuote(topic),
                              " found more than once,\n",
                              "using the one found in ",
                              sQuote(dirname(f)),
                              sep = ""),
                        call. = FALSE)
                ## </FIXME>
            }
            if(length(f)) {
                ## <FIXME>
                ## Should really abstract this into a BioC style
                ## openPDF() along the lines of browseURL() ...
                if(.Platform$OS == "windows")
                    shell.exec(f)
                else
                    system(paste(Sys.getenv("R_PDFVIEWER"), f, "&"))
                ## </FIXME>
            }
            else
                warning(paste("vignette", sQuote(topic), "has no PDF"),
                        call. = FALSE)
        }
        else
            warning(paste("vignette", sQuote(topic), "*not* found"),
                    call. = FALSE)
    }

    if(missing(topic)) {
        ## List all possible vignettes.

        vDB <- matrix(character(0), nr = 0, nc = 4)
        colnames(vDB) <- c("Dir", "File", "Title", "PDF")

        for(db in vignettes[sapply(vignettes, length) > 0]) {
            dir <- dirname(dirname(db[1]))
            entries <- NULL
            ## Check for new-style 'Meta/vignette.rds' ...
            if(file.exists(INDEX <-
                           file.path(dir, "Meta", "vignette.rds"))) {
                entries <- .readRDS(INDEX)
            }
            else {
                ## ... if not found, let tools:::.buildVignetteIndex()
                ## do the job, including worrying about old-style
                ## 'doc/00Index.dcf' files.
                ## <FIXME>
                ## Currently not exported, should it be?
                entries <-
                    tools:::.buildVignetteIndex(file.path(dir, "doc"))
                ## </FIXME>
            }
            if(NROW(entries) > 0)
                vDB <-
                    rbind(vDB,
                          cbind(Dir = I(dir),
                                entries[c("File", "Title", "PDF")]))
        }

        ## Now compute info on available PDFs ...
        title <- if(NROW(vDB) > 0) {
            paste(vDB[, "Title"],
                  paste(rep.int("(source", NROW(vDB)),
                        ifelse(vDB[, "PDF"] != "", ", pdf", ""),
                        ")",
                        sep = ""))
        }
        else
            character()
        ## ... and rewrite into the form used by packageIQR.
        db <- cbind(Package = basename(vDB[, "Dir"]),
                    LibPath = dirname(vDB[, "Dir"]),
                    Item = tools::filePathSansExt(basename(vDB[, "File"])),
                    Title = title)

        y <- list(type = "vignette", title = "Vignettes", header = NULL,
                  results = db, footer = NULL)
        class(y) <- "packageIQR"
        return(y)
    }
}
.noGenerics <- TRUE
