The R Project SVN R

dev.list <-
    function()
{
    if(exists(".Devices")) {
    n <- get(".Devices")
    }
    else {
    n <- list("null device")
    }
    n <- unlist(n)
    i <- seq(along = n)[n != ""]
    names(i) <- n[i]
    i <- i[-1]
    if(length(i) == 0)
    return(NULL)
    else i
}

dev.cur <-
    function()
{
    if(!exists(".Devices")) {
    .Devices <- list("null device")
    }
    num.device <- .Internal(dev.cur())
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.set <-
    function(which = dev.next())
{
    which <- .Internal(dev.set(as.integer(which)))
    if(exists(".Devices")) {
    assign(".Device", get(".Devices")[[which]])
    }
    else {
    .Devices <- list("null device")
    }
    names(which) <- .Devices[[which]]
    which
}

dev.next <-
    function(which = dev.cur())
{
    if(!exists(".Devices"))
    .Devices <- list("null.device")
    num.device <- .Internal(dev.next(as.integer(which)))
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.prev <-
    function(which = dev.cur())
{
    if(!exists(".Devices"))
    .Devices <- list("null device")
    num.device <- .Internal(dev.prev(as.integer(which)))
    names(num.device) <- .Devices[[num.device]]
    num.device
}

dev.off <-
    function(which = dev.cur())
{
    if(which == 1)
    stop("Cannot shut down device 1 (the null device)")
    if(exists(".Devices")) {
    .Devices <- get(".Devices")
    }
    else {
    .Devices <- list("null device")
    }
    .Devices[[which]] <- ""
    assign(".Devices", .Devices)
    .Internal(dev.off(as.integer(which)))
    assign(".Device", .Devices[[dev.cur()]])
    dev.cur()
}

dev.copy <- function(device, ..., which = dev.next())
{
    if(!missing(which) & !missing(device))
    stop("Cannot supply which and device at the same time.")
    old.device <- dev.cur()
    if(old.device == 1)
    stop("Cannot copy the null device.")
    if(missing(device)) {
    if(which == 1)
        stop("Cannot copy to the null device.")
    else if(which == dev.cur())
        stop("Cannot copy device to itself")
    dev.set(which)
    }
    else {
    if(!is.function(device))
        stop("Argument 'device' should be a function")
    else device(...)
    }
    .Internal(dev.copy(old.device))
    dev.cur()
}

dev.print <- function(device = postscript, ...)
{
    current.device <- dev.cur()
    dev.off(dev.copy(device = device, ...)) # user must still print this
    dev.set(current.device)
}

dev.control <- function(displaylist)
{
    if(!missing(displaylist)) {
    if(displaylist == "inhibit")
        .Internal(dev.control())
    else stop(paste("displaylist should be inhibit"))
    }
    invisible()
}

graphics.off <- function ()
{
    while ((which <- dev.cur()) != 1)
    dev.off(which)
}