The R Project SVN R

/*
 *  R : A Computer Language for Statistical Data Analysis
 *  Copyright (C) 1995, 1996    Robert Gentleman and Ross Ihaka
 *  Copyright (C) 2000--2006    The R Development 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.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, a copy is available at
 *  http://www.r-project.org/Licenses/
 *
 *
 *  EXPORTS printMatrix()
 *      printArray()
 *
 *  See ./printutils.c   for general remarks on Printing
 *           and the Encode.. utils.
 *
 *  See ./format.c   for the  format_FOO_  functions used below.
 */

/* <UTF8> char here is handled as a whole,
   but lengths were used as display widths */

#ifdef HAVE_CONFIG_H
#include <config.h>
#endif

#include "Defn.h"
#include "Print.h"

#include <stdlib.h> /* for div() */

/* FIXME: sort out encodings */
/* We need display width of a string */
int Rstrwid(const char *str, int slen, int enc, int quote);  /* from printutils.c */
#define strwidth(x) Rstrwid(x, strlen(x), CE_NATIVE, 0)

/* ceil_DIV(a,b) :=  ceil(a / b)  in _int_ arithmetic : */
static R_INLINE
int ceil_DIV(int a, int b)
{
    div_t div_res = div(a, b);
    return div_res.quot + ((div_res.rem != 0) ? 1 : 0);
}

/* moved from printutils.c */

static void MatrixColumnLabel(SEXP cl, int j, int w)
{
    int l;
    SEXP tmp;

    if (!isNull(cl)) {
        tmp = STRING_ELT(cl, j);
    if(tmp == NA_STRING) l = R_print.na_width_noquote;
    else l = Rstrlen(tmp, 0);
    Rprintf("%*s%s", w-l, "",
        EncodeString(tmp, l, 0, Rprt_adj_left));
    }
    else {
    Rprintf("%*s[,%ld]", w-IndexWidth(j+1)-3, "", j+1);
    }
}

static void RightMatrixColumnLabel(SEXP cl, int j, int w)
{
    int l;
    SEXP tmp;

    if (!isNull(cl)) {
        tmp = STRING_ELT(cl, j);
    if(tmp == NA_STRING) l = R_print.na_width_noquote;
    else l = Rstrlen(tmp, 0);
    /* This does not work correctly at least on FC3
    Rprintf("%*s", R_print.gap+w,
        EncodeString(tmp, l, 0, Rprt_adj_right)); */
    Rprintf("%*s%s", R_print.gap+w-l, "",
            EncodeString(tmp, l, 0, Rprt_adj_right));
    }
    else {
    Rprintf("%*s[,%ld]%*s", R_print.gap, "", j+1, w-IndexWidth(j+1)-3, "");
    }
}

static void LeftMatrixColumnLabel(SEXP cl, int j, int w)
{
    int l;
    SEXP tmp;

    if (!isNull(cl)) {
        tmp= STRING_ELT(cl, j);
    if(tmp == NA_STRING) l = R_print.na_width_noquote;
    else l = Rstrlen(tmp, 0);
    Rprintf("%*s%s%*s", R_print.gap, "",
        EncodeString(tmp, l, 0, Rprt_adj_left), w-l, "");
    }
    else {
    Rprintf("%*s[,%ld]%*s", R_print.gap, "", j+1, w-IndexWidth(j+1)-3, "");
    }
}

static void MatrixRowLabel(SEXP rl, int i, int rlabw, int lbloff)
{
    int l;
    SEXP tmp;

    if (!isNull(rl)) {
        tmp= STRING_ELT(rl, i);
    if(tmp == NA_STRING) l = R_print.na_width_noquote;
    else l = Rstrlen(tmp, 0);
    Rprintf("\n%*s%s%*s", lbloff, "",
        EncodeString(tmp, l, 0, Rprt_adj_left),
        rlabw-l-lbloff, "");
    }
    else {
    Rprintf("\n%*s[%ld,]", rlabw-3-IndexWidth(i + 1), "", i+1);
    }
}



/* This is the first (of 6)  print<TYPE>Matrix()  functions.
 * We define macros that will be re-used in the other functions,
 * and comment the common code here (only):
*/
static void printLogicalMatrix(SEXP sx, int offset, int r_pr, int r, int c,
                   SEXP rl, SEXP cl, const char *rn, const char *cn)
{
    int *x;

/* initialization; particularly of row labels, rl= dimnames(.)[[1]] and
 * rn = names(dimnames(.))[1] : */
#define _PRINT_INIT_rl_rn               \
    SEXP sw;                        \
    int *w;                     \
    int width, rlabw = -1, clabw = -1; /* -Wall */  \
    int i, j, jmin = 0, jmax = 0, lbloff = 0;       \
                            \
    if (!isNull(rl))                    \
    formatString(STRING_PTR(rl), r, &rlabw, 0); \
    else                        \
    rlabw = IndexWidth(r + 1) + 3;          \
                            \
    if (rn) {                       \
    int rnw = strwidth(rn);             \
    if ( rnw < rlabw + R_MIN_LBLOFF )       \
        lbloff = R_MIN_LBLOFF;          \
    else                        \
        lbloff = rnw - rlabw;           \
                            \
    rlabw += lbloff;                \
    }

    _PRINT_INIT_rl_rn;

    sw = allocVector(INTSXP, c);
    x = LOGICAL(sx) + offset;
    w = INTEGER(sw);
    /* compute w[j] = column-width of j(+1)-th column : */
    for (j = 0; j < c; j++) {
    formatLogical(&x[j * r], r, &w[j]);

#   define _PRINT_SET_clabw                 \
                                \
    if (!isNull(cl)) {                  \
        if(STRING_ELT(cl, j) == NA_STRING)          \
        clabw = R_print.na_width_noquote;       \
        else clabw = strwidth(translateChar(STRING_ELT(cl, j)));    \
    } else                          \
        clabw = IndexWidth(j + 1) + 3;

    _PRINT_SET_clabw;

    if (w[j] < clabw)
        w[j] = clabw;
    w[j] += R_print.gap;
    }

#   define _PRINT_DEAL_c_eq_0               \
                            \
    if (c == 0) {                   \
    for (i = 0; i < r; i++)             \
        MatrixRowLabel(rl, i, rlabw, lbloff);   \
    Rprintf("\n");                  \
    return;                     \
    }
    _PRINT_DEAL_c_eq_0;

    while (jmin < c) {
    /* print columns  jmin:(jmax-1)  where jmax has to be determined first */

    width = rlabw;
    /* initially, jmax = jmin */
    do {
        width += w[jmax]; jmax++;

    } while (jmax < c && width + w[jmax] < R_print.width);

#   define _PRINT_ROW_LAB           \
                        \
    if (cn != NULL)             \
        Rprintf("%*s%s\n", rlabw, "", cn);  \
                        \
    if (rn != NULL)             \
        Rprintf("%*s", -rlabw, rn);     \
    else                    \
        Rprintf("%*s", rlabw, "");

    _PRINT_ROW_LAB;

    for (j = jmin; j < jmax ; j++)
        MatrixColumnLabel(cl, j, w[j]);
    for (i = 0; i < r_pr; i++) {
        MatrixRowLabel(rl, i, rlabw, lbloff); /* starting with an "\n" */
        for (j = jmin; j < jmax; j++) {
        Rprintf("%s", EncodeLogical(x[i + j * r], w[j]));
        }
    }
    Rprintf("\n");
    jmin = jmax;
    }
}

static void printIntegerMatrix(SEXP sx, int offset, int r_pr, int r, int c,
                   SEXP rl, SEXP cl, const char *rn, const char *cn)
{
    int *x;

    _PRINT_INIT_rl_rn;

    sw = allocVector(INTSXP, c);
    x = INTEGER(sx) + offset;
    w = INTEGER(sw);
    for (j = 0; j < c; j++) {
    formatInteger(&x[j * r], r, &w[j]);
    _PRINT_SET_clabw;
    if (w[j] < clabw)
        w[j] = clabw;
    w[j] += R_print.gap;
    }
    _PRINT_DEAL_c_eq_0;
    while (jmin < c) {
    width = rlabw;
    do {
        width += w[jmax];
        jmax++;
    }
    while (jmax < c && width + w[jmax] < R_print.width);

    _PRINT_ROW_LAB;

    for (j = jmin; j < jmax ; j++)
        MatrixColumnLabel(cl, j, w[j]);
    for (i = 0; i < r_pr; i++) {
        MatrixRowLabel(rl, i, rlabw, lbloff);
        for (j = jmin; j < jmax; j++) {
        Rprintf("%s", EncodeInteger(x[i + j * r], w[j]));
        }
    }
    Rprintf("\n");
    jmin = jmax;
    }
}

static void printRealMatrix(SEXP sx, int offset, int r_pr, int r, int c,
                SEXP rl, SEXP cl, const char *rn, const char *cn)
{
    SEXP sd, se;
    double *x;
    int *d, *e;
    _PRINT_INIT_rl_rn;

    PROTECT(sd = allocVector(INTSXP, c));
    PROTECT(se = allocVector(INTSXP, c));
    sw = allocVector(INTSXP, c);
    UNPROTECT(2);
    x = REAL(sx) + offset;
    d = INTEGER(sd);
    e = INTEGER(se);
    w = INTEGER(sw);

    for (j = 0; j < c; j++) {
    formatReal(&x[j * r], r, &w[j], &d[j], &e[j], 0);
    _PRINT_SET_clabw;
    if (w[j] < clabw)
        w[j] = clabw;
    w[j] += R_print.gap;
    }
    _PRINT_DEAL_c_eq_0;
    while (jmin < c) {
    width = rlabw;
    do {
        width += w[jmax];
        jmax++;
    }
    while (jmax < c && width + w[jmax] < R_print.width);

    _PRINT_ROW_LAB;

    for (j = jmin; j < jmax ; j++)
        MatrixColumnLabel(cl, j, w[j]);
    for (i = 0; i < r_pr; i++) {
        MatrixRowLabel(rl, i, rlabw, lbloff);
        for (j = jmin; j < jmax; j++) {
        Rprintf("%s", EncodeReal(x[i + j * r], w[j], d[j], e[j], OutDec));
        }
    }
    Rprintf("\n");
    jmin = jmax;
    }
}

static void printComplexMatrix(SEXP sx, int offset, int r_pr, int r, int c,
                   SEXP rl, SEXP cl, const char *rn, const char *cn)
{
    SEXP sdr, ser, swr, sdi, sei, swi;
    Rcomplex *x;
    int *dr, *er, *wr, *di, *ei, *wi;
    _PRINT_INIT_rl_rn;

    PROTECT(sdr = allocVector(INTSXP, c));
    PROTECT(ser = allocVector(INTSXP, c));
    PROTECT(swr = allocVector(INTSXP, c));
    PROTECT(sdi = allocVector(INTSXP, c));
    PROTECT(sei = allocVector(INTSXP, c));
    PROTECT(swi = allocVector(INTSXP, c));
    PROTECT(sw  = allocVector(INTSXP, c));
    UNPROTECT(7);
    x = COMPLEX(sx) + offset;
    dr = INTEGER(sdr);
    er = INTEGER(ser);
    wr = INTEGER(swr);
    di = INTEGER(sdi);
    ei = INTEGER(sei);
    wi = INTEGER(swi);
    w = INTEGER(sw);

    /* Determine the column widths */

    for (j = 0; j < c; j++) {
    formatComplex(&x[j * r], r,
              &wr[j], &dr[j], &er[j],
              &wi[j], &di[j], &ei[j], 0);
    _PRINT_SET_clabw;
    w[j] = wr[j] + wi[j] + 2;
    if (w[j] < clabw)
        w[j] = clabw;
    w[j] += R_print.gap;
    }

    _PRINT_DEAL_c_eq_0;
    while (jmin < c) {
    width = rlabw;
    do {
        width += w[jmax];
        jmax++;
    }
    while (jmax < c && width + w[jmax] < R_print.width);

    _PRINT_ROW_LAB;

    for (j = jmin; j < jmax ; j++)
        MatrixColumnLabel(cl, j, w[j]);
    for (i = 0; i < r_pr; i++) {
        MatrixRowLabel(rl, i, rlabw, lbloff);
        for (j = jmin; j < jmax; j++) {
        if (ISNA(x[i + j * r].r) || ISNA(x[i + j * r].i))
            Rprintf("%s", EncodeReal(NA_REAL, w[j], 0, 0, OutDec));
        else
            Rprintf("%s",
                EncodeComplex(x[i + j * r],
                      wr[j] + R_print.gap, dr[j], er[j],
                      wi[j], di[j], ei[j], OutDec));
        }
    }
    Rprintf("\n");
    jmin = jmax;
    }
}

static void printStringMatrix(SEXP sx, int offset, int r_pr, int r, int c,
                  int quote, int right, SEXP rl, SEXP cl,
                  const char *rn, const char *cn)
{
    SEXP *x;
    _PRINT_INIT_rl_rn;

    sw = allocVector(INTSXP, c);
    x = STRING_PTR(sx)+offset;
    w = INTEGER(sw);
    for (j = 0; j < c; j++) {
    formatString(&x[j * r], r, &w[j], quote);
    _PRINT_SET_clabw;
    if (w[j] < clabw)
        w[j] = clabw;
    }
    _PRINT_DEAL_c_eq_0;
    while (jmin < c) {
    width = rlabw;
    do {
        width += w[jmax] + R_print.gap;
        jmax++;
    }
    while (jmax < c && width + w[jmax] + R_print.gap < R_print.width);

    _PRINT_ROW_LAB;

    if (right) {
        for (j = jmin; j < jmax ; j++)
        RightMatrixColumnLabel(cl, j, w[j]);
    }
    else {
        for (j = jmin; j < jmax ; j++)
        LeftMatrixColumnLabel(cl, j, w[j]);
    }
    for (i = 0; i < r_pr; i++) {
        MatrixRowLabel(rl, i, rlabw, lbloff);
        for (j = jmin; j < jmax; j++) {
        Rprintf("%*s%s", R_print.gap, "",
            EncodeString(x[i + j * r], w[j], quote, right));
        }
    }
    Rprintf("\n");
    jmin = jmax;
    }
}

static void printRawMatrix(SEXP sx, int offset, int r_pr, int r, int c,
               SEXP rl, SEXP cl, const char *rn, const char *cn)
{
    Rbyte *x;
    _PRINT_INIT_rl_rn;

    sw = allocVector(INTSXP, c);
    x = RAW(sx) + offset;
    w = INTEGER(sw);
    for (j = 0; j < c; j++) {
    formatRaw(&x[j * r], r, &w[j]);
    _PRINT_SET_clabw;
    if (w[j] < clabw)
        w[j] = clabw;
    w[j] += R_print.gap;
    }
    _PRINT_DEAL_c_eq_0;
    while (jmin < c) {
    width = rlabw;
    do {
        width += w[jmax];
        jmax++;
    }
    while (jmax < c && width + w[jmax] < R_print.width);

    _PRINT_ROW_LAB;

    for (j = jmin; j < jmax ; j++)
        MatrixColumnLabel(cl, j, w[j]);
    for (i = 0; i < r_pr; i++) {
        MatrixRowLabel(rl, i, rlabw, lbloff);
        for (j = jmin; j < jmax; j++)
        Rprintf("%*s%s", w[j]-2, "", EncodeRaw(x[i + j * r]));
    }
    Rprintf("\n");
    jmin = jmax;
    }
}

void printMatrix(SEXP x, int offset, SEXP dim, int quote, int right,
         SEXP rl, SEXP cl, const char *rn, const char *cn)
{
/* 'rl' and 'cl' are dimnames(.)[[1]] and dimnames(.)[[2]]  whereas
 * 'rn' and 'cn' are the  names(dimnames(.))
 */
    int r = INTEGER(dim)[0];
    int c = INTEGER(dim)[1], r_pr;
    /* PR#850 */
    if ((rl != R_NilValue) && (r > length(rl)))
    error(_("too few row labels"));
    if ((cl != R_NilValue) && (c > length(cl)))
    error(_("too few column labels"));
    if (r == 0 && c == 0) {
    Rprintf("<0 x 0 matrix>\n");
    return;
    }
    r_pr = r;
    if(c > 0 && R_print.max / c < r) /* avoid integer overflow */
    /* using floor(), not ceil(), since 'c' could be huge: */
    r_pr = R_print.max / c;
    switch (TYPEOF(x)) {
    case LGLSXP:
    printLogicalMatrix(x, offset, r_pr, r, c, rl, cl, rn, cn);
    break;
    case INTSXP:
    printIntegerMatrix(x, offset, r_pr, r, c, rl, cl, rn, cn);
    break;
    case REALSXP:
    printRealMatrix   (x, offset, r_pr, r, c, rl, cl, rn, cn);
    break;
    case CPLXSXP:
    printComplexMatrix(x, offset, r_pr, r, c, rl, cl, rn, cn);
    break;
    case STRSXP:
    if (quote) quote = '"';
    printStringMatrix (x, offset, r_pr, r, c, quote, right, rl, cl, rn, cn);
    break;
    case RAWSXP:
    printRawMatrix    (x, offset, r_pr, r, c, rl, cl, rn, cn);
    break;
    default:
    UNIMPLEMENTED_TYPE("printMatrix", x);
    }
#ifdef ENABLE_NLS
    if(r_pr < r) /* FIXME? use _P() and "Defn.h" ? */
    Rprintf(ngettext(" [ reached getOption(\"max.print\") -- omitted last row ]]\n",
             " [ reached getOption(\"max.print\") -- omitted %d rows ]]\n",
             r - r_pr),
        r - r_pr);
#else
    if(r_pr < r) /* FIXME? use _P() and "Defn.h" ? */
    Rprintf(" [ reached getOption(\"max.print\") -- omitted %d rows ]]\n",
        r - r_pr);
#endif
}

static void printArrayGeneral(SEXP x, SEXP dim, int quote, int right,
                  SEXP dimnames)
{
/* == printArray(.) */

    int ndim = LENGTH(dim);
    const char *rn = NULL, *cn = NULL;

    if (ndim == 1)
    printVector(x, 1, quote);
    else if (ndim == 2) {
    SEXP rl, cl;
    GetMatrixDimnames(x, &rl, &cl, &rn, &cn);
    printMatrix(x, 0, dim, quote, 0, rl, cl, rn, cn);
    }
    else { /* ndim >= 3 */
    SEXP dn, dnn, dn0, dn1;
    int i, j, has_dimnames, has_dnn, nb, nb_pr;
    int nr = INTEGER(dim)[0], nr_last;
    int nc = INTEGER(dim)[1];
    int b = nr * nc;
    Rboolean max_reached;

    if (dimnames == R_NilValue) {
        has_dimnames = 0;
        has_dnn = 0;
        dn0 = R_NilValue;
        dn1 = R_NilValue;
        dnn = R_NilValue; /* -Wall */
    }
    else {
        dn0 = VECTOR_ELT(dimnames, 0);
        dn1 = VECTOR_ELT(dimnames, 1);
        has_dimnames = 1;
        dnn = getAttrib(dimnames, R_NamesSymbol);
        has_dnn = !isNull(dnn);
        if ( has_dnn ) {
        rn = (char *) translateChar(STRING_ELT(dnn, 0));
        cn = (char *) translateChar(STRING_ELT(dnn, 1));
        }
    }
    /* nb := #{entries} in a slice such as x[1,1,..] or equivalently,
     *       the number of matrix slices   x[ , , *, ..]  which
     *       are printed as matrices -- if options("max.print") allows */
    for (i = 2, nb = 1; i < ndim; i++)
        nb *= INTEGER(dim)[i];
    max_reached = (b > 0 && R_print.max / b < nb);
    if (max_reached) { /* i.e., also  b > 0, nr > 0, nc > 0, nb > 0 */
        /* nb_pr := the number of matrix slices to be printed */
        nb_pr = ceil_DIV(R_print.max, b);
        /* for the last, (nb_pr)th matrix slice, use only nr_last rows;
         *  using floor(), not ceil(), since 'nc' could be huge: */
        nr_last = (R_print.max - b * (nb_pr - 1)) / nc;
        if(nr_last == 0) { nb_pr--; nr_last = nr; }
    } else {
        nb_pr = nb;
        nr_last = nr;
    }
    for (i = 0; i < nb_pr; i++) {
        int k = 1, use_nr = nr;
        if (i == nb_pr - 1) { /* for the last slice :*/
        use_nr = nr_last;
        }
        Rprintf(", ");
        for (j = 2 ; j < ndim; j++) {
        int l = (i / k) % INTEGER(dim)[j] + 1;
        if (has_dimnames &&
            ((dn = VECTOR_ELT(dimnames, j)) != R_NilValue)) {
            if ( has_dnn )
            Rprintf(", %s = %s",
                translateChar(STRING_ELT(dnn, j)),
                translateChar(STRING_ELT(dn, l - 1)));
            else
            Rprintf(", %s", translateChar(STRING_ELT(dn, l - 1)));
        } else
            Rprintf(", %d", l);
        k = k * INTEGER(dim)[j];
        }
        Rprintf("\n\n");
        switch (TYPEOF(x)) {
        case LGLSXP:
        printLogicalMatrix(x, i * b, use_nr, nr, nc, dn0, dn1, rn, cn);
        break;
        case INTSXP:
        printIntegerMatrix(x, i * b, use_nr, nr, nc, dn0, dn1, rn, cn);
        break;
        case REALSXP:
        printRealMatrix   (x, i * b, use_nr, nr, nc, dn0, dn1, rn, cn);
        break;
        case CPLXSXP:
        printComplexMatrix(x, i * b, use_nr, nr, nc, dn0, dn1, rn, cn);
        break;
        case STRSXP:
        if (quote) quote = '"';
        printStringMatrix (x, i * b, use_nr, nr, nc,
                   quote, right, dn0, dn1, rn, cn);
        break;
        case RAWSXP:
        printRawMatrix    (x, i * b, use_nr, nr, nc, dn0, dn1, rn, cn);
        break;
        }
        Rprintf("\n");
    }

    if(max_reached && nb_pr < nb) {
        Rprintf(" [ reached getOption(\"max.print\") -- omitted");
        if(nr_last < nr) Rprintf(" %d row(s) and", nr - nr_last);
        Rprintf(" %d matrix slice(s) ]\n", nb - nb_pr);
    }
    }
}

void printArray(SEXP x, SEXP dim, int quote, int right, SEXP dimnames)
{
    printArrayGeneral(x, dim, quote, right, dimnames);
}