The R Project SVN R

#  File src/library/utils/R/de.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2013 The R Core Team
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/

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

de.setup <- function(ilist, list.names, incols)
{
    ilen <- sum(incols)
    ivec <- vector("list", ilen)
    inames <- vector("list", ilen)
    i <- 1L
    k <- 0L
    for( telt in ilist ) {
    k <- k+1L
    if( is.list(telt) ) {
        y <- names(telt)
        for( j in seq_along(telt) ) {
        ivec[[i]] <- telt[[j]]
        if( is.null(y) || y[j]=="" )
            inames[[i]] <- paste0("var", i)
        else inames[[i]] <- y[j]
        i <- i+1L
        }
    }
    else if( is.vector(telt) ) {
        ivec[[i]] <- telt
        inames[[i]] <- list.names[[k]]
        i <- i+1
    }
    else if( is.matrix(telt) ) {
        y <- dimnames(telt)[[2L]]
        for( j in seq_len(ncol(telt)) ) {
        ivec[[i]] <- telt[, j]
        if( is.null(y) || y[j]=="" )
            inames[[i]] <- paste0("var", i)
        else inames[[i]] <- y[j]
        i <- i+1L
        }
    }
    else stop("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 <- 1L
    lnames <- names(inlist)
    if(p) for(i in seq_len(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 seq_len(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+1L
        }
        if( nrow(x) == nrow(args[[i]]) )
        rn <- dimnames(args[[i]])[[1L]]
        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 seq_len(ncols[i])) {
        x[[ind1]] <- inlist[[j]]
        cnames[ind1] <- lnames[j]
        j <- j+1L
        }
        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(...))[-1L])
    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[, 2L]
    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 != 1L)) {
    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 <- 1L
    nn <- names(tmp1)
    for(i in nn) {
    assign(i, tmp1[[j]], envir=.GlobalEnv)
    j <- j+1L
    }
    if(j == 1L) warning("did not assign() anything")
    invisible(nn)
}