The R Project SVN R

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
 *
 *  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.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 */

/*== see ./printutils.c  for general remarks on Printing and the Encode.. utils.
 *   see ./format.c  for the  format_Foo_  functions.
 */
#include "Defn.h"
#include "Print.h"

SEXP mkChar(char *);

/*  .Internal(paste(args, sep, collapse)) */

/* do_paste uses two passes to paste the arguments (in CAR(args)) together.
 * The first pass calculates the width of the paste buffer,
 * then it is alloc-ed and the second pass stuffs the information in.
 */
SEXP do_paste(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP ans, collapse, sep, px, x, tmpchar;
    int i, k, maxlen, nx, pwidth, sepw;
    char *s, *buf;

    checkArity(op, args);

        /* We use formatting and so we */
        /* must initialize printing. */

    PrintDefaults(env);

        /* Check the arguments */

    x = CAR(args);
    if (!isList(x))
        errorcall(call, "invalid first argument\n");

    sep = CADR(args);
    if (!isString(sep) || LENGTH(sep) <= 0)
        errorcall(call, "invalid separator\n");
    sep = STRING(sep)[0];
    sepw = LENGTH(sep);

    collapse = CADDR(args);
    if (!isNull(collapse))
        if(!isString(collapse) || LENGTH(collapse) <= 0)
            errorcall(call, "invalid collapse argument\n");

        /* Maximum argument length and */
        /* check for arguments of list type */

    nx = length(x);
    maxlen = 0;
    for (px = x; px != R_NilValue; px = CDR(px)) {
        if (!isString(CAR(px)))
            error("non-string argument to Internal paste\n");
        if(length(CAR(px)) > maxlen)
            maxlen = length(CAR(px));
    }
    if(maxlen == 0) return mkString("");

    PROTECT(ans = allocVector(STRSXP, maxlen));

    for (i = 0; i < maxlen; i++) {
        pwidth = 0;
        for (px = x; px != R_NilValue; px = CDR(px)) {
            k = length(CAR(px));
            if (k > 0)
                pwidth += LENGTH(STRING(CAR(px))[i%k]);
        }
        pwidth += (nx - 1) * sepw;
        tmpchar = allocString(pwidth);
        buf = CHAR(tmpchar);
        for (px=x; px != R_NilValue; px = CDR(px)) {
            k = length(CAR(px));
            if (k > 0) {
                s = CHAR(STRING(CAR(px))[i%k]);
                sprintf(buf, "%s", s);
                buf += LENGTH(STRING(CAR(px))[i%k]);
            }
            if (CDR(px) != R_NilValue && sepw != 0) {
                sprintf(buf, "%s", CHAR(sep));
                buf += sepw;
            }
        }
        STRING(ans)[i] = tmpchar;
    }

        /* Now collapse, if required. */

    if(collapse != R_NilValue && (nx=LENGTH(ans)) != 0) {
        sep = STRING(collapse)[0];
        sepw = LENGTH(sep);
        pwidth = 0;
        for (i = 0; i < nx; i++)
            pwidth += LENGTH(STRING(ans)[i]);
        pwidth += (nx - 1) * sepw;
        tmpchar = allocString(pwidth);
        buf = CHAR(tmpchar);
        for (i = 0; i < nx; i++) {
            if(i > 0) {
                sprintf(buf, "%s", CHAR(sep));
                buf += sepw;
            }
            s = CHAR(STRING(ans)[i]);
            sprintf(buf, "%s", s);
            buf += LENGTH(STRING(ans)[i]);
        }
        PROTECT(tmpchar);
        ans = allocVector(STRSXP, 1);
        UNPROTECT(1);
        STRING(ans)[0] = tmpchar;
    }
    UNPROTECT(1);
    return ans;
}

SEXP do_format(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP l, nastring, x, y;
    int i, n, nl, trim;
    int w, d, e;
    int wi, di, ei;
    char *strp;

    PrintDefaults(env);

    switch (length(args)) {
    case 1:
        trim = 0;
        break;
    case 2:
        trim = asLogical(CADR(args));
        if (trim == NA_INTEGER)
            errorcall(call, "invalid \"trim\" argument\n");
        break;
    default:
        errorcall(call, "incorrect number of arguments\n"); trim=0;
    }

    if (!isVector(x = CAR(args)))
        errorcall(call, "first argument must be atomic\n");

    if ((n = LENGTH(x)) <= 0)
        return allocVector(STRSXP, 0);

    switch (TYPEOF(x)) {
    case LGLSXP:
        PROTECT(y = allocVector(STRSXP, n));
        if (trim)
            w = 0;
        else
            formatLogical(LOGICAL(x), n, &w);
        for (i = 0; i < n; i++) {
            strp = EncodeLogical(LOGICAL(x)[i], w);
            STRING(y)[i] = mkChar(strp);
        }
        UNPROTECT(1);
        break;
    case INTSXP:
        PROTECT(y = allocVector(STRSXP, n));
        if (trim) w = 0;
        else formatInteger(INTEGER(x), n, &w);
        for (i = 0; i < n; i++) {
            strp = EncodeInteger(INTEGER(x)[i], w);
            STRING(y)[i] = mkChar(strp);
        }
        UNPROTECT(1);
        break;
    case REALSXP:
        formatReal(REAL(x), n, &w, &d, &e);
        if (trim) w = 0;
        PROTECT(y = allocVector(STRSXP, n));
        for (i = 0; i < n; i++) {
            strp = EncodeReal(REAL(x)[i], w, d, e);
            STRING(y)[i] = mkChar(strp);
        }
        UNPROTECT(1);
        break;
    case CPLXSXP:
        formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei);
        if (trim) wi = w = 0;
        PROTECT(y = allocVector(STRSXP, n));
        for (i = 0; i < n; i++) {
            strp = EncodeComplex(COMPLEX(x)[i], w, d, e, wi, di, ei);
            STRING(y)[i] = mkChar(strp);
        }
        UNPROTECT(1);
        break;
    case STRSXP:
        formatString(STRING(x), n, &w, 0);
        if (trim) w = 0;
        PROTECT(y = allocVector(STRSXP, n));
        for (i = 0; i < n; i++) {
            strp = EncodeString(CHAR(STRING(x)[i]), w, 0, adj_left);
            STRING(y)[i] = mkChar(strp);
        }
        UNPROTECT(1);
        break;
    }
    PROTECT(y);
    if((l = getAttrib(x, R_DimSymbol)) != R_NilValue)
        setAttrib(y, R_DimSymbol, l);
    if((l = getAttrib(x, R_DimNamesSymbol)) != R_NilValue)
        setAttrib(y, R_DimNamesSymbol, l);
    UNPROTECT(1);
    return y;
}

/* format.info(obj)  --> 3 integers  (w,d,e) with the formatting information
 *          w = total width (#{chars}) per item
 *          d = #{digits} to RIGHT of "."
 *          e = {0:2}.   0: Fixpoint;
 *                 1,2: exponential with 2/3 digit expon.
 */
SEXP do_formatinfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
    SEXP l, x;
    int n, w, d, e;
    int wi, di, ei;
    checkArity(op, args);
    x = CAR(args);
    n = LENGTH(x);
    w = 0;
    d = 0;
    e = 0;
    switch(TYPEOF(x))
    {
        case LGLSXP:
            formatLogical(LOGICAL(x), n, &w);
            break;
        case INTSXP:
            formatInteger(INTEGER(x), n, &w);
            break;
        case REALSXP:
            formatReal(REAL(x), n, &w, &d, &e);
            break;
        case CPLXSXP:
            wi = di = ei = 0;
            formatComplex(COMPLEX(x), n, &w, &d, &e, &wi, &di, &ei);
            n = -1;/* complex 'code' */
            break;
        case STRSXP:
            formatString(STRING(x), n, &w, 0);
            break;
        default:
            errorcall(call, "vector arguments only\n");
    }
    x = allocVector(INTSXP, (n>=0)?3:6);
    INTEGER(x)[0] = w;
    INTEGER(x)[1] = d;
    INTEGER(x)[2] = e;
    if(n<0) { /*- complex -*/
        INTEGER(x)[3] = wi;
        INTEGER(x)[4] = di;
        INTEGER(x)[5] = ei;
    }
    return x;
}