The R Project SVN R

Rev

Rev 90229 | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
830 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
89383 smeyer 3 
 *  Copyright (C) 1998-2026  The R Core Team.
830 maechler 4 
 *  Copyright (C) 1995-1998  Robert Gentleman and Ross Ihaka
2 r 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
42307 ripley 17 
 *  along with this program; if not, a copy is available at
68947 ripley 18 
 *  https://www.R-project.org/Licenses/
2 r 19 
 */
20 
 
38979 ripley 21 
/* The x:y  primitive calls do_colon(); do_colon() calls cross_colon() if
22 
   both arguments are factors and seq_colon() otherwise.
23 
 */
830 maechler 24 
 
5187 hornik 25 
#ifdef HAVE_CONFIG_H
7701 hornik 26 
#include <config.h>
5187 hornik 27 
#endif
28 
 
11499 ripley 29 
#include <Defn.h>
60667 ripley 30 
#include <Internal.h>
51838 ripley 31 
#include <float.h>  /* for DBL_EPSILON */
11499 ripley 32 
#include <Rmath.h>
68663 luke 33 
#include <R_ext/Itermacros.h>
2 r 34 
 
41899 ripley 35 
#include "RBufferUtils.h"
36 
static R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
37 
 
48206 maechler 38 
#define _S4_rep_keepClass
39 
/* ==>  rep(<S4>, .) keeps class e.g., for list-like */
40 
 
38979 ripley 41 
static SEXP cross_colon(SEXP call, SEXP s, SEXP t)
2 r 42 
{
37355 ripley 43 
    SEXP a, la, ls, lt, rs, rt;
59096 ripley 44 
    int i, j, k, n, nls, nlt;
41495 rgentlem 45 
    char *cbuf;
63181 ripley 46 
    const void *vmax = vmaxget();
4562 pd 47 
 
38979 ripley 48 
    if (length(s) != length(t))
49 
	errorcall(call, _("unequal factor lengths"));
4562 pd 50 
    n = length(s);
37355 ripley 51 
    ls = getAttrib(s, R_LevelsSymbol);
52 
    lt = getAttrib(t, R_LevelsSymbol);
53 
    nls = LENGTH(ls);
54 
    nlt = LENGTH(lt);
4562 pd 55 
    PROTECT(a = allocVector(INTSXP, n));
37355 ripley 56 
    PROTECT(rs = coerceVector(s, INTSXP));
57 
    PROTECT(rt = coerceVector(t, INTSXP));
4562 pd 58 
    for (i = 0; i < n; i++) {
59096 ripley 59 
	int vs = INTEGER(rs)[i];
60 
	int vt = INTEGER(rt)[i];
4562 pd 61 
	if ((vs == NA_INTEGER) || (vt == NA_INTEGER))
62 
	    INTEGER(a)[i] = NA_INTEGER;
63 
	else
64 
	    INTEGER(a)[i] = vt + (vs - 1) * nlt;
65 
    }
37355 ripley 66 
    UNPROTECT(2);
4562 pd 67 
    if (!isNull(ls) && !isNull(lt)) {
68 
	PROTECT(la = allocVector(STRSXP, nls * nlt));
69 
	k = 0;
44091 ripley 70 
	/* FIXME: possibly UTF-8 version */
4562 pd 71 
	for (i = 0; i < nls; i++) {
44059 ripley 72 
	    const char *vi = translateChar(STRING_ELT(ls, i));
59096 ripley 73 
	    size_t vs = strlen(vi);
4562 pd 74 
	    for (j = 0; j < nlt; j++) {
44059 ripley 75 
		const char *vj = translateChar(STRING_ELT(lt, j));
62580 ripley 76 
		size_t vt = strlen(vj), len = vs + vt + 2;
77 
		cbuf = R_AllocStringBuffer(len, &cbuff);
78 
		snprintf(cbuf, len, "%s:%s", vi, vj);
45446 ripley 79 
		SET_STRING_ELT(la, k, mkChar(cbuf));
4562 pd 80 
		k++;
81 
	    }
82 
	}
83 
	setAttrib(a, R_LevelsSymbol, la);
84 
	UNPROTECT(1);
85 
    }
41894 ripley 86 
    PROTECT(la = mkString("factor"));
4562 pd 87 
    setAttrib(a, R_ClassSymbol, la);
88 
    UNPROTECT(2);
41899 ripley 89 
    R_FreeStringBufferL(&cbuff);
63181 ripley 90 
    vmaxset(vmax);
91 
    return a;
4562 pd 92 
}
93 
 
60160 ripley 94 
/* interval at which to check interrupts */
84385 kalibera 95 
/*   if re-enabling, consider a power of two */
96 
/* #define NINTERRUPT 1000000U */
60160 ripley 97 
 
41715 ripley 98 
static SEXP seq_colon(double n1, double n2, SEXP call)
4562 pd 99 
{
64275 ripley 100 
    double r = fabs(n2 - n1);
68923 ripley 101 
    if(r >= R_XLEN_T_MAX)
59451 ripley 102 
	errorcall(call, _("result would be too long a vector"));
571 ihaka 103 
 
74244 luke 104 
    if (n1 == (R_xlen_t) n1 && n2 == (R_xlen_t) n2)
74268 ripley 105 
	return R_compact_intrange((R_xlen_t) n1, (R_xlen_t) n2);
74244 luke 106 
 
64275 ripley 107 
    SEXP ans;
108 
    R_xlen_t n = (R_xlen_t)(r + 1 + FLT_EPSILON);
48823 maechler 109 
 
64275 ripley 110 
    Rboolean useInt = (n1 <= INT_MAX) &&  (n1 == (int) n1);
48823 maechler 111 
    if(useInt) {
87507 maechler 112 
	if(n1 <= INT_MIN) /* know  n1 <= INT_MAX */
48823 maechler 113 
	    useInt = FALSE;
114 
	else {
115 
	    /* r := " the effective 'to' "  of  from:to */
59178 ripley 116 
	    double dn = (double) n;
117 
	    r = n1 + ((n1 <= n2) ? dn-1 : -(dn-1));
87891 ripley 118 
	    if(r <= INT_MIN || r > INT_MAX) useInt = false;
48823 maechler 119 
	}
120 
    }
28452 ripley 121 
    if (useInt) {
1839 ihaka 122 
	if (n1 <= n2)
74268 ripley 123 
	    ans = R_compact_intrange((R_xlen_t) n1, (R_xlen_t)(n1 + n - 1));
1839 ihaka 124 
	else
74268 ripley 125 
	    ans = R_compact_intrange((R_xlen_t) n1, (R_xlen_t)(n1 - n + 1));
1839 ihaka 126 
    } else {
127 
	ans = allocVector(REALSXP, n);
128 
	if (n1 <= n2)
60160 ripley 129 
	    for (R_xlen_t i = 0; i < n; i++) {
60336 ripley 130 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
60160 ripley 131 
		REAL(ans)[i] = n1 + (double)i;
132 
	    }
1839 ihaka 133 
	else
60160 ripley 134 
	    for (R_xlen_t i = 0; i < n; i++) {
60336 ripley 135 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
60160 ripley 136 
		REAL(ans)[i] = n1 - (double)i;
137 
	    }
1839 ihaka 138 
    }
139 
    return ans;
2 r 140 
}
141 
 
83446 ripley 142 
attribute_hidden SEXP do_colon(SEXP call, SEXP op, SEXP args, SEXP rho)
2 r 143 
{
1839 ihaka 144 
    checkArity(op, args);
84019 maechler 145 
    SEXP s1 = CAR(args),
146 
	s2 = CADR(args);
147 
    if (inherits(s1, "factor") && inherits(s2, "factor"))
148 
	return(cross_colon(call, s1, s2));
149 
    double
150 
	n1 = length(s1),
151 
	n2 = length(s2);
152 
    if (n1 != 1 || n2 != 1) {
153 
	if (n1 == 0 || n2 == 0)
154 
	    errorcall(call, _("argument of length 0"));
155 
	char *check = getenv("_R_CHECK_LENGTH_COLON_");
87891 ripley 156 
	if (check ? StringTrue(check) : false) // warn by default
84019 maechler 157 
	    errorcall(call, _("numerical expression has length > 1"));
158 
	else
159 
	    warningcall(call, _("numerical expression has %d elements: only the first used"),
160 
			(n1 > 1) ? (int) n1 : (int) n2);
161 
    }
38997 ripley 162 
 
163 
    n1 = asReal(s1);
164 
    n2 = asReal(s2);
165 
    if (ISNAN(n1) || ISNAN(n2))
166 
	errorcall(call, _("NA/NaN argument"));
41715 ripley 167 
    return seq_colon(n1, n2, call);
2 r 168 
}
169 
 
59900 ripley 170 
/* rep.int(x, times) for a vector times */
2 r 171 
static SEXP rep2(SEXP s, SEXP ncopy)
172 
{
71914 maechler 173 
    R_xlen_t i, j, nc, n;
59895 ripley 174 
    SEXP a, t;
2 r 175 
 
71922 maechler 176 
#define R2_SWITCH_LOOP(it) \
71914 maechler 177 
    switch (TYPEOF(s)) { \
178 
    case LGLSXP: \
179 
	for (i = 0; i < nc; i++) { \
180 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
181 
	    for (j = 0; j < (R_xlen_t) it[i]; j++) \
182 
		LOGICAL(a)[n++] = LOGICAL(s)[i]; \
183 
	} \
184 
	break; \
185 
    case INTSXP: \
186 
	for (i = 0; i < nc; i++) { \
187 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 188 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 189 
		INTEGER(a)[n++] = INTEGER(s)[i]; \
190 
	} \
191 
	break; \
192 
    case REALSXP: \
193 
	for (i = 0; i < nc; i++) { \
194 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 195 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 196 
		REAL(a)[n++] = REAL(s)[i]; \
197 
	} \
198 
	break; \
199 
    case CPLXSXP: \
200 
	for (i = 0; i < nc; i++) { \
201 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 202 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 203 
		COMPLEX(a)[n++] = COMPLEX(s)[i]; \
204 
	} \
205 
	break; \
206 
    case STRSXP: \
207 
	for (i = 0; i < nc; i++) { \
208 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 209 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 210 
		SET_STRING_ELT(a, n++, STRING_ELT(s, i)); \
211 
	} \
212 
	break; \
213 
    case VECSXP: \
214 
    case EXPRSXP: \
215 
	for (i = 0; i < nc; i++) { \
216 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
217 
	    SEXP elt = lazy_duplicate(VECTOR_ELT(s, i)); \
71996 maechler 218 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 219 
		SET_VECTOR_ELT(a, n++, elt); \
220 
	} \
221 
	break; \
222 
    case RAWSXP: \
223 
	for (i = 0; i < nc; i++) { \
224 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 225 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 226 
		RAW(a)[n++] = RAW(s)[i]; \
227 
	} \
228 
	break; \
229 
    default: \
230 
	UNIMPLEMENTED_TYPE("rep2", s); \
231 
    }
232 
 
233 
#ifdef LONG_VECTOR_SUPPORT
234 
    if (TYPEOF(ncopy) != INTSXP)
235 
#else
236 
    if (TYPEOF(ncopy) == REALSXP)
237 
#endif
72292 ripley 238 
	PROTECT(t = coerceVector(ncopy, REALSXP));
71914 maechler 239 
    else
72292 ripley 240 
	PROTECT(t = coerceVector(ncopy, INTSXP));
2 r 241 
 
59052 ripley 242 
    nc = xlength(ncopy);
71914 maechler 243 
    double sna = 0;
244 
    if (TYPEOF(t) == REALSXP)
1839 ihaka 245 
    for (i = 0; i < nc; i++) {
60336 ripley 246 
//	if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
71914 maechler 247 
	if (ISNAN(REAL(t)[i]) || REAL(t)[i] <= -1 ||
248 
	    REAL(t)[i] >= R_XLEN_T_MAX+1.0)
249 
	    error(_("invalid '%s' value"), "times");
250 
	sna += (R_xlen_t) REAL(t)[i];
251 
    }
252 
    else
253 
    for (i = 0; i < nc; i++) {
254 
//	if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59892 ripley 255 
	if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i] < 0)
41715 ripley 256 
	    error(_("invalid '%s' value"), "times");
71914 maechler 257 
	sna += INTEGER(t)[i];
1839 ihaka 258 
    }
71914 maechler 259 
    if (sna > R_XLEN_T_MAX)
260 
	error(_("invalid '%s' value"), "times");
261 
    R_xlen_t na = (R_xlen_t) sna;
2 r 262 
 
60336 ripley 263 
/*    R_xlen_t ni = NINTERRUPT, ratio;
60213 ripley 264 
    if(nc > 0) {
265 
	ratio = na/nc; // average no of replications
266 
	if (ratio > 1000U) ni = 1000U;
60336 ripley 267 
	} */
59895 ripley 268 
    PROTECT(a = allocVector(TYPEOF(s), na));
1839 ihaka 269 
    n = 0;
71922 maechler 270 
    if (TYPEOF(t) == REALSXP)
271 
	R2_SWITCH_LOOP(REAL(t))
272 
    else
273 
	R2_SWITCH_LOOP(INTEGER(t))
1839 ihaka 274 
    UNPROTECT(2);
275 
    return a;
2 r 276 
}
71914 maechler 277 
#undef R2_SWITCH_LOOP
2 r 278 
 
59900 ripley 279 
/* rep_len(x, len), also used for rep.int() with scalar 'times' */
59918 ripley 280 
static SEXP rep3(SEXP s, R_xlen_t ns, R_xlen_t na)
2 r 281 
{
59918 ripley 282 
    R_xlen_t i, j;
59892 ripley 283 
    SEXP a;
2 r 284 
 
59895 ripley 285 
    PROTECT(a = allocVector(TYPEOF(s), na));
2 r 286 
 
59909 ripley 287 
    switch (TYPEOF(s)) {
288 
    case LGLSXP:
68663 luke 289 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 290 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 291 
	    LOGICAL(a)[i] = LOGICAL(s)[j];
292 
	});
59909 ripley 293 
	break;
294 
    case INTSXP:
68663 luke 295 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 296 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 297 
	    INTEGER(a)[i] = INTEGER(s)[j];
298 
	});
59909 ripley 299 
	break;
300 
    case REALSXP:
68663 luke 301 
	MOD_ITERATE1(na, ns, i, j,  {
60336 ripley 302 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 303 
	    REAL(a)[i] = REAL(s)[j];
304 
	});
59909 ripley 305 
	break;
306 
    case CPLXSXP:
68663 luke 307 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 308 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 309 
	    COMPLEX(a)[i] = COMPLEX(s)[j];
310 
	});
59909 ripley 311 
	break;
312 
    case RAWSXP:
68663 luke 313 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 314 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 315 
	    RAW(a)[i] = RAW(s)[j];
316 
	});
59909 ripley 317 
	break;
318 
    case STRSXP:
68663 luke 319 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 320 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 321 
	    SET_STRING_ELT(a, i, STRING_ELT(s, j));
322 
	});
59909 ripley 323 
	break;
324 
    case VECSXP:
59921 ripley 325 
    case EXPRSXP:
68663 luke 326 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 327 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 328 
	    SET_VECTOR_ELT(a, i, lazy_duplicate(VECTOR_ELT(s, j)));
329 
	});
59909 ripley 330 
	break;
331 
    default:
332 
	UNIMPLEMENTED_TYPE("rep3", s);
59885 ripley 333 
    }
59895 ripley 334 
    UNPROTECT(1);
59892 ripley 335 
    return a;
336 
}
337 
 
72271 maechler 338 
// .Internal(rep.int(x, times))
83446 ripley 339 
attribute_hidden SEXP do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
59892 ripley 340 
{
341 
    checkArity(op, args);
342 
    SEXP s = CAR(args), ncopy = CADR(args);
343 
    R_xlen_t nc;
344 
    SEXP a;
345 
 
77888 hornik 346 
    /* DispatchOrEval internal generic: rep.int */
74659 lawrence 347 
    if (DispatchOrEval(call, op, "rep.int", args, rho, &a, 0, 0))
348 
      return(a);
349 
 
89383 smeyer 350 
    if (!inherits(s, "factor"))
77905 lawrence 351 
    if (DispatchOrEval(call, op, "rep", args, rho, &a, 0, 0))
352 
      return(a);
80483 maechler 353 
 
59892 ripley 354 
    if (!isVector(ncopy))
72271 maechler 355 
	error(_("invalid type (%s) for '%s' (must be a vector)"),
85146 luke 356 
	      R_typeToChar(ncopy), "times");
59892 ripley 357 
 
59895 ripley 358 
    if (!isVector(s) && s != R_NilValue)
68923 ripley 359 
	error(_("attempt to replicate an object of type '%s'"),
85146 luke 360 
	      R_typeToChar(s));
59892 ripley 361 
 
362 
    nc = xlength(ncopy); // might be 0
72271 maechler 363 
    if (nc == xlength(s))
59909 ripley 364 
	PROTECT(a = rep2(s, ncopy));
59892 ripley 365 
    else {
366 
	if (nc != 1) error(_("invalid '%s' value"), "times");
68923 ripley 367 
 
71914 maechler 368 
	R_xlen_t ns = xlength(s);
369 
	if (TYPEOF(ncopy) != INTSXP) {
72292 ripley 370 
	    double snc = asReal(ncopy);
371 
	    if (!R_FINITE(snc) || snc <= -1. ||
372 
		(ns > 0 && snc >= R_XLEN_T_MAX + 1.))
373 
		error(_("invalid '%s' value"), "times");
374 
	    nc = ns == 0 ? 1 : (R_xlen_t) snc;
375 
	} else if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0) // nc = 0 ok
59892 ripley 376 
	    error(_("invalid '%s' value"), "times");
71914 maechler 377 
	if ((double) nc * ns > R_XLEN_T_MAX)
378 
	    error(_("invalid '%s' value"), "times");
59918 ripley 379 
	PROTECT(a = rep3(s, ns, nc * ns));
59892 ripley 380 
    }
381 
 
382 
#ifdef _S4_rep_keepClass
383 
    if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
384 
	setAttrib(a, R_ClassSymbol, getAttrib(s, R_ClassSymbol));
385 
	SET_S4_OBJECT(a);
386 
    }
387 
#endif
388 
 
59885 ripley 389 
    if (inherits(s, "factor")) {
390 
	SEXP tmp;
391 
	if(inherits(s, "ordered")) {
392 
	    PROTECT(tmp = allocVector(STRSXP, 2));
393 
	    SET_STRING_ELT(tmp, 0, mkChar("ordered"));
394 
	    SET_STRING_ELT(tmp, 1, mkChar("factor"));
395 
	} else PROTECT(tmp = mkString("factor"));
396 
	setAttrib(a, R_ClassSymbol, tmp);
397 
	UNPROTECT(1);
398 
	setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
399 
    }
400 
    UNPROTECT(1);
401 
    return a;
402 
}
403 
 
83446 ripley 404 
attribute_hidden SEXP do_rep_len(SEXP call, SEXP op, SEXP args, SEXP rho)
59892 ripley 405 
{
59918 ripley 406 
    R_xlen_t ns, na;
59892 ripley 407 
    SEXP a, s, len;
59885 ripley 408 
 
59892 ripley 409 
    checkArity(op, args);
74659 lawrence 410 
 
77888 hornik 411 
    /* DispatchOrEval internal generic: rep_len */
74659 lawrence 412 
    if (DispatchOrEval(call, op, "rep_len", args, rho, &a, 0, 0))
413 
      return(a);
414 
 
59892 ripley 415 
    s = CAR(args);
416 
 
89383 smeyer 417 
    if (isObject(s) && !inherits(s, "factor")) {
77906 ripley 418 
	SEXP rep_call;
77905 lawrence 419 
	PROTECT(rep_call = shallow_duplicate(call));
420 
	SETCAR(rep_call, install("rep"));
421 
	SET_TAG(CDDR(rep_call), install("length.out"));
422 
	SET_TAG(CDR(args), install("length.out"));
423 
	if (DispatchOrEval(rep_call, op, "rep", args, rho, &a, 0, 0)) {
424 
	    UNPROTECT(1);
425 
	    return(a);
426 
	}
427 
	UNPROTECT(1);
428 
    }
80483 maechler 429 
 
59895 ripley 430 
    if (!isVector(s) && s != R_NilValue)
59892 ripley 431 
	error(_("attempt to replicate non-vector"));
432 
 
433 
    len = CADR(args);
434 
    if(length(len) != 1)
435 
	error(_("invalid '%s' value"), "length.out");
71914 maechler 436 
    if (TYPEOF(len) != INTSXP) {
72292 ripley 437 
	double sna = asReal(len);
438 
	if (ISNAN(sna) || sna <= -1. || sna >= R_XLEN_T_MAX + 1.)
439 
	    error(_("invalid '%s' value"), "length.out");
440 
	na = (R_xlen_t) sna;
71914 maechler 441 
    } else
72292 ripley 442 
	if ((na = asInteger(len)) == NA_INTEGER || na < 0) /* na = 0 ok */
443 
	    error(_("invalid '%s' value"), "length.out");
59892 ripley 444 
 
59909 ripley 445 
    if (TYPEOF(s) == NILSXP && na > 0)
446 
	error(_("cannot replicate NULL to a non-zero length"));
59918 ripley 447 
    ns = xlength(s);
448 
    if (ns == 0) {
59909 ripley 449 
	SEXP a;
450 
	PROTECT(a = duplicate(s));
451 
	if(na > 0) a = xlengthgets(a, na);
452 
	UNPROTECT(1);
453 
	return a;
454 
    }
59918 ripley 455 
    PROTECT(a = rep3(s, ns, na));
59892 ripley 456 
 
457 
#ifdef _S4_rep_keepClass
458 
    if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
459 
	setAttrib(a, R_ClassSymbol, getAttrib(s, R_ClassSymbol));
460 
	SET_S4_OBJECT(a);
461 
    }
462 
#endif
463 
 
464 
    if (inherits(s, "factor")) {
465 
	SEXP tmp;
466 
	if(inherits(s, "ordered")) {
467 
	    PROTECT(tmp = allocVector(STRSXP, 2));
468 
	    SET_STRING_ELT(tmp, 0, mkChar("ordered"));
469 
	    SET_STRING_ELT(tmp, 1, mkChar("factor"));
470 
	} else PROTECT(tmp = mkString("factor"));
471 
	setAttrib(a, R_ClassSymbol, tmp);
472 
	UNPROTECT(1);
473 
	setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
474 
    }
475 
    UNPROTECT(1);
476 
    return a;
477 
}
478 
 
71611 maechler 479 
/* rep(), allowing for both times and each ;
480 
 * -----  nt == length(times) ;  if (nt == 1)  'times' is *not* accessed  */
71914 maechler 481 
static SEXP rep4(SEXP x, SEXP times, R_xlen_t len, R_xlen_t each, R_xlen_t nt)
59900 ripley 482 
{
483 
    SEXP a;
484 
    R_xlen_t lx = xlength(x);
485 
    R_xlen_t i, j, k, k2, k3, sum;
59918 ripley 486 
 
487 
    // faster code for common special case
488 
    if (each == 1 && nt == 1) return rep3(x, lx, len);
489 
 
59900 ripley 490 
    PROTECT(a = allocVector(TYPEOF(x), len));
491 
 
72292 ripley 492 
#define R4_SWITCH_LOOP(itimes)						\
493 
    switch (TYPEOF(x)) {						\
494 
    case LGLSXP:							\
495 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
496 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
497 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
498 
	    for(k3 = 0; k3 < sum; k3++) {				\
499 
		LOGICAL(a)[k2++] = LOGICAL(x)[i];			\
500 
		if(k2 == len) goto done;				\
501 
	    }								\
502 
	}								\
503 
	break;								\
504 
    case INTSXP:							\
505 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
506 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
507 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
508 
	    for(k3 = 0; k3 < sum; k3++) {				\
509 
		INTEGER(a)[k2++] = INTEGER(x)[i];			\
510 
		if(k2 == len) goto done;				\
511 
	    }								\
512 
	}								\
513 
	break;								\
514 
    case REALSXP:							\
515 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
516 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
517 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
518 
	    for(k3 = 0; k3 < sum; k3++) {				\
519 
		REAL(a)[k2++] = REAL(x)[i];				\
520 
		if(k2 == len) goto done;				\
521 
	    }								\
522 
	}								\
523 
	break;								\
524 
    case CPLXSXP:							\
525 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
526 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
527 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
528 
	    for(k3 = 0; k3 < sum; k3++) {				\
529 
		COMPLEX(a)[k2++] = COMPLEX(x)[i];			\
530 
		if(k2 == len) goto done;				\
531 
	    }								\
532 
	}								\
533 
	break;								\
534 
    case STRSXP:							\
535 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
536 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
537 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
538 
	    for(k3 = 0; k3 < sum; k3++) {				\
539 
		SET_STRING_ELT(a, k2++, STRING_ELT(x, i));		\
540 
		if(k2 == len) goto done;				\
541 
	    }								\
542 
	}								\
543 
	break;								\
544 
    case VECSXP:							\
545 
    case EXPRSXP:							\
546 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
547 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
548 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
77655 luke 549 
	    SEXP elt = lazy_duplicate(VECTOR_ELT(x, i));		\
72292 ripley 550 
	    for(k3 = 0; k3 < sum; k3++) {				\
77655 luke 551 
		SET_VECTOR_ELT(a, k2++, elt);				\
72292 ripley 552 
		if(k2 == len) goto done;				\
553 
	    }								\
554 
	}								\
555 
	break;								\
556 
    case RAWSXP:							\
557 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
558 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
559 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
560 
	    for(k3 = 0; k3 < sum; k3++) {				\
561 
		RAW(a)[k2++] = RAW(x)[i];				\
562 
		if(k2 == len) goto done;				\
563 
	    }								\
564 
	}								\
565 
	break;								\
566 
    default:								\
567 
	UNIMPLEMENTED_TYPE("rep4", x);					\
71914 maechler 568 
    }
569 
 
570 
    if(nt == 1)
72292 ripley 571 
	switch (TYPEOF(x)) {
572 
	case LGLSXP:
60160 ripley 573 
	    for(i = 0; i < len; i++) {
60336 ripley 574 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 575 
		LOGICAL(a)[i] = LOGICAL(x)[(i/each) % lx];
60160 ripley 576 
	    }
72292 ripley 577 
	    break;
578 
	case INTSXP:
60160 ripley 579 
	    for(i = 0; i < len; i++) {
60336 ripley 580 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 581 
		INTEGER(a)[i] = INTEGER(x)[(i/each) % lx];
60160 ripley 582 
	    }
72292 ripley 583 
	    break;
584 
	case REALSXP:
60160 ripley 585 
	    for(i = 0; i < len; i++) {
60336 ripley 586 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 587 
		REAL(a)[i] = REAL(x)[(i/each) % lx];
60160 ripley 588 
	    }
72292 ripley 589 
	    break;
590 
	case CPLXSXP:
60160 ripley 591 
	    for(i = 0; i < len; i++) {
60336 ripley 592 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 593 
		COMPLEX(a)[i] = COMPLEX(x)[(i/each) % lx];
60160 ripley 594 
	    }
72292 ripley 595 
	    break;
596 
	case STRSXP:
60160 ripley 597 
	    for(i = 0; i < len; i++) {
60336 ripley 598 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 599 
		SET_STRING_ELT(a, i, STRING_ELT(x, (i/each) % lx));
60160 ripley 600 
	    }
72292 ripley 601 
	    break;
602 
	case VECSXP:
603 
	case EXPRSXP:
60160 ripley 604 
	    for(i = 0; i < len; i++) {
60336 ripley 605 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
77655 luke 606 
		SEXP elt = lazy_duplicate(VECTOR_ELT(x, (i/each) % lx));
607 
		SET_VECTOR_ELT(a, i, elt);
60160 ripley 608 
	    }
72292 ripley 609 
	    break;
610 
	case RAWSXP:
60160 ripley 611 
	    for(i = 0; i < len; i++) {
60336 ripley 612 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 613 
		RAW(a)[i] = RAW(x)[(i/each) % lx];
60160 ripley 614 
	    }
72292 ripley 615 
	    break;
616 
	default:
617 
	    UNIMPLEMENTED_TYPE("rep4", x);
618 
	}
71922 maechler 619 
    else if(TYPEOF(times) == REALSXP)
620 
	R4_SWITCH_LOOP(REAL(times))
72292 ripley 621 
	else
622 
	    R4_SWITCH_LOOP(INTEGER(times))
623 
		done:
624 
	    UNPROTECT(1);
59900 ripley 625 
    return a;
626 
}
71914 maechler 627 
#undef R4_SWITCH_LOOP
59900 ripley 628 
 
38997 ripley 629 
/* We are careful to use evalListKeepMissing here (inside
630 
   DispatchOrEval) to avoid dropping missing arguments so e.g.
631 
   rep(1:3,,8) matches length.out */
51245 ripley 632 
 
633 
/* This is a primitive SPECIALSXP with internal argument matching */
83446 ripley 634 
attribute_hidden SEXP do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
38994 ripley 635 
{
71611 maechler 636 
    SEXP ans, x, times = R_NilValue;
71914 maechler 637 
    R_xlen_t i, lx, len = NA_INTEGER, each = 1, nt;
66326 luke 638 
    static SEXP do_rep_formals = NULL;
38994 ripley 639 
 
59900 ripley 640 
    /* includes factors, POSIX[cl]t, Date */
77888 hornik 641 
    /* DispatchOrEval internal generic: rep */
40093 ripley 642 
    if (DispatchOrEval(call, op, "rep", args, rho, &ans, 0, 0))
40056 ripley 643 
	return(ans);
40093 ripley 644 
 
38997 ripley 645 
    /* This has evaluated all the non-missing arguments into ans */
646 
    PROTECT(args = ans);
38994 ripley 647 
 
38997 ripley 648 
    /* This is a primitive, and we have not dispatched to a method
38994 ripley 649 
       so we manage the argument matching ourselves.  We pretend this is
650 
       rep(x, times, length.out, each, ...)
651 
    */
66326 luke 652 
    if (do_rep_formals == NULL)
68923 ripley 653 
	do_rep_formals = allocFormalsList5(install("x"), install("times"),
66326 luke 654 
					   install("length.out"),
655 
					   install("each"), R_DotsSymbol);
77452 luke 656 
    PROTECT(args = matchArgs_NR(do_rep_formals, args, call));
38994 ripley 657 
 
45446 ripley 658 
    x = CAR(args);
61272 ripley 659 
    /* supported in R 2.15.x */
59900 ripley 660 
    if (TYPEOF(x) == LISTSXP)
661 
	errorcall(call, "replication of pairlists is defunct");
662 
 
59056 ripley 663 
    lx = xlength(x);
38994 ripley 664 
 
71914 maechler 665 
    if (TYPEOF(CADDR(args)) != INTSXP) {
72292 ripley 666 
	double slen = asReal(CADDR(args));
667 
	if (R_FINITE(slen)) {
668 
	    if (slen <= -1 || slen >= R_XLEN_T_MAX+1.0)
669 
		errorcall(call, _("invalid '%s' argument"), "length.out");
670 
	    len = (R_xlen_t) slen;
671 
	} else
672 
	    len = NA_INTEGER;
59056 ripley 673 
    } else {
674 
	len = asInteger(CADDR(args));
675 
	if(len != NA_INTEGER && len < 0)
676 
	    errorcall(call, _("invalid '%s' argument"), "length.out");
677 
    }
54198 ripley 678 
    if(length(CADDR(args)) != 1)
68923 ripley 679 
	warningcall(call, _("first element used of '%s' argument"),
54198 ripley 680 
		    "length.out");
38994 ripley 681 
 
71914 maechler 682 
    if (TYPEOF(CADDDR(args)) != INTSXP) {
683 
	double seach = asReal(CADDDR(args));
684 
	if (R_FINITE(seach)) {
72292 ripley 685 
	    if (seach <= -1. || (lx > 0 && seach >= R_XLEN_T_MAX + 1.))
71914 maechler 686 
		errorcall(call, _("invalid '%s' argument"), "each");
687 
	    each = lx == 0 ? NA_INTEGER : (R_xlen_t) seach;
688 
	} else each = NA_INTEGER;
689 
    } else {
72292 ripley 690 
	each = asInteger(CADDDR(args));
691 
	if(each != NA_INTEGER && each < 0)
692 
	    errorcall(call, _("invalid '%s' argument"), "each");
71914 maechler 693 
    }
54198 ripley 694 
    if(length(CADDDR(args)) != 1)
695 
	warningcall(call, _("first element used of '%s' argument"), "each");
38994 ripley 696 
    if(each == NA_INTEGER) each = 1;
697 
 
698 
    if(lx == 0) {
68923 ripley 699 
	if(len > 0 && x == R_NilValue)
59890 ripley 700 
	    warningcall(call, "'x' is NULL so the result will be NULL");
59885 ripley 701 
	SEXP a;
702 
	PROTECT(a = duplicate(x));
72979 maechler 703 
	if(len != NA_INTEGER && len > 0 && x != R_NilValue)
704 
	    a = xlengthgets(a, len);
66326 luke 705 
	UNPROTECT(3);
59885 ripley 706 
	return a;
38994 ripley 707 
    }
59966 ripley 708 
    if (!isVector(x))
709 
	errorcall(call, "attempt to replicate an object of type '%s'",
85146 luke 710 
		  R_typeToChar(x));
38994 ripley 711 
 
59900 ripley 712 
    /* So now we know x is a vector of positive length.  We need to
713 
       replicate it, and its names if it has them. */
714 
 
71914 maechler 715 
    int nprotect = 2;
59900 ripley 716 
    /* First find the final length using 'times' and 'each' */
38994 ripley 717 
    if(len != NA_INTEGER) { /* takes precedence over times */
718 
	nt = 1;
719 
    } else {
71914 maechler 720 
	double sum = 0;
721 
	if(CADR(args) == R_MissingArg)
722 
	    PROTECT(times = ScalarInteger(1));
723 
#ifdef LONG_VECTOR_SUPPORT
724 
	else if(TYPEOF(CADR(args)) != INTSXP)
725 
#else
726 
	else if(TYPEOF(CADR(args)) == REALSXP)
727 
#endif
728 
	    PROTECT(times = coerceVector(CADR(args), REALSXP));
729 
	else PROTECT(times = coerceVector(CADR(args), INTSXP));
730 
	nprotect++;
731 
	nt = XLENGTH(times);
39848 ripley 732 
	if(nt == 1) {
71611 maechler 733 
	    R_xlen_t it;
71914 maechler 734 
	    if (TYPEOF(times) == REALSXP) {
735 
		double rt = REAL(times)[0];
736 
		if (ISNAN(rt) || rt <= -1 || rt >= R_XLEN_T_MAX+1.0)
71636 maechler 737 
		    errorcall(call, _("invalid '%s' argument"), "times");
738 
		it = (R_xlen_t) rt;
71914 maechler 739 
	    } else {
740 
		it = INTEGER(times)[0];
71636 maechler 741 
		if (it == NA_INTEGER || it < 0)
742 
		    errorcall(call, _("invalid '%s' argument"), "times");
71611 maechler 743 
	    }
71914 maechler 744 
	    if ((double) lx * it * each > R_XLEN_T_MAX)
88638 maechler 745 
		errorcall(call, _("length(x) * '%s' * '%s' is too large"), "times", "each");
50305 falcon 746 
	    len = lx * it * each;
71914 maechler 747 
	} else { // nt != 1
88638 maechler 748 
	    if(nt != (double) lx * each) {
749 
		if (each == 1)	errorcall(call, _("invalid '%s' argument"),			     "times");
750 
		/* else */	errorcall(call, _("invalid '%s' argument, given the value of '%s'"), "times", "each");
751 
	    }
71914 maechler 752 
	    if (TYPEOF(times) == REALSXP)
72292 ripley 753 
		for(i = 0; i < nt; i++) {
754 
		    double rt = REAL(times)[i];
755 
		    if (ISNAN(rt) || rt <= -1 || rt >= R_XLEN_T_MAX+1.0)
756 
			errorcall(call, _("invalid '%s' argument"), "times");
757 
		    sum += (R_xlen_t) rt;
758 
		}
71914 maechler 759 
	    else
72292 ripley 760 
		for(i = 0; i < nt; i++) {
761 
		    int it = INTEGER(times)[i];
762 
		    if (it == NA_INTEGER || it < 0)
763 
			errorcall(call, _("invalid '%s' argument"), "times");
764 
		    sum += it;
765 
		}
71914 maechler 766 
	    if (sum > R_XLEN_T_MAX)
767 
		errorcall(call, _("invalid '%s' argument"), "times");
768 
	    len = (R_xlen_t) sum;
38994 ripley 769 
	}
770 
    }
59900 ripley 771 
 
40984 ripley 772 
    if(len > 0 && each == 0)
773 
	errorcall(call, _("invalid '%s' argument"), "each");
59900 ripley 774 
 
71914 maechler 775 
    SEXP xn = PROTECT(getAttrib(x, R_NamesSymbol));  nprotect++;
776 
    PROTECT(ans = rep4(x, times, len, each, nt));    nprotect++;
777 
 
778 
    if (xlength(xn) > 0)
59900 ripley 779 
	setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
780 
 
48206 maechler 781 
#ifdef _S4_rep_keepClass
47083 maechler 782 
    if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
783 
	setAttrib(ans, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
784 
	SET_S4_OBJECT(ans);
785 
    }
48206 maechler 786 
#endif
38994 ripley 787 
    UNPROTECT(nprotect);
788 
    return ans;
789 
}
38997 ripley 790 
 
791 
 
45446 ripley 792 
/*
87507 maechler 793 
  This is a primitive SPECIALSXP with internal argument matching, implementing
51245 ripley 794 
 
87507 maechler 795 
  seq.int(from, to, by, length.out, along.with, ...)
796 
 
797 
  'along' has to be used on an unevaluated argument, and evalList
798 
  tries to evaluate language objects.
38997 ripley 799 
 */
51095 ripley 800 
#define FEPS 1e-10
50879 ripley 801 
/* to match seq.default */
83446 ripley 802 
attribute_hidden SEXP do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
38997 ripley 803 
{
66326 luke 804 
    SEXP ans = R_NilValue /* -Wall */, from, to, by, len, along;
59056 ripley 805 
    R_xlen_t i, lout = NA_INTEGER;
87891 ripley 806 
    bool One = (length(args) == 1); // *before* messing with args ..
38997 ripley 807 
 
77888 hornik 808 
    /* DispatchOrEval internal generic: seq.int */
53179 ripley 809 
    if (DispatchOrEval(call, op, "seq", args, rho, &ans, 0, 1))
40056 ripley 810 
	return(ans);
38997 ripley 811 
 
53179 ripley 812 
    /* This is a primitive and we manage argument matching ourselves.
813 
       We pretend this is
85451 ripley 814 
       seq.int(from, to, by, length.out, along.with, ...)
38997 ripley 815 
    */
80483 maechler 816 
    static SEXP do_seq_formals = NULL;
66326 luke 817 
    if (do_seq_formals == NULL)
68923 ripley 818 
	do_seq_formals = allocFormalsList6(install("from"), install("to"),
66326 luke 819 
					   install("by"), install("length.out"),
820 
					   install("along.with"), R_DotsSymbol);
77452 luke 821 
    PROTECT(args = matchArgs_NR(do_seq_formals, args, call));
38997 ripley 822 
 
823 
    from = CAR(args); args = CDR(args);
71917 maechler 824 
    to   = CAR(args); args = CDR(args);
825 
    by   = CAR(args); args = CDR(args);
826 
    len  = CAR(args); args = CDR(args);
827 
    along= CAR(args);
87891 ripley 828 
    bool
71917 maechler 829 
	miss_from = (from == R_MissingArg),
830 
	miss_to   = (to   == R_MissingArg);
831 
    if(One && !miss_from) {
80483 maechler 832 
	int lf = length(from);
63303 ripley 833 
	if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
834 
	    double rfrom = asReal(from);
835 
	    if (!R_FINITE(rfrom))
71917 maechler 836 
		errorcall(call, _("'%s' must be a finite number"), "from");
63303 ripley 837 
	    ans = seq_colon(1.0, rfrom, call);
838 
	}
87507 maechler 839 
	else if (lf) // typically  seq(<vec>) , length(<vec>) >= 2
41715 ripley 840 
	    ans = seq_colon(1.0, (double)lf, call);
38997 ripley 841 
	else
842 
	    ans = allocVector(INTSXP, 0);
843 
	goto done;
844 
    }
845 
    if(along != R_MissingArg) {
90229 luke 846 
	lout = xlength(along);
38997 ripley 847 
	if(One) {
41715 ripley 848 
	    ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
38997 ripley 849 
	    goto done;
850 
	}
851 
    } else if(len != R_MissingArg && len != R_NilValue) {
852 
	double rout = asReal(len);
85451 ripley 853 
	if(!R_FINITE(rout))
854 
	    errorcall(call, _("'%s' must be a finite number"), "length.out");
38997 ripley 855 
	if(ISNAN(rout) || rout <= -0.5)
856 
	    errorcall(call, _("'length.out' must be a non-negative number"));
54198 ripley 857 
	if(length(len) != 1)
68923 ripley 858 
	    warningcall(call, _("first element used of '%s' argument"),
54198 ripley 859 
			"length.out");
85451 ripley 860 
	rout = ceil(rout);
861 
	if(rout >= R_XLEN_T_MAX)
862 
	    errorcall(call, _("result would be too long a vector"));
863 
	lout = (R_xlen_t) rout;
38997 ripley 864 
    }
865 
 
866 
    if(lout == NA_INTEGER) {
80483 maechler 867 
	double rfrom, rto;
71917 maechler 868 
	if(miss_from) rfrom = 1.0;
869 
	else {
71923 maechler 870 
	    if(length(from) != 1) errorcall(call, _("'%s' must be of length 1"), "from");
71917 maechler 871 
	    rfrom = asReal(from);
872 
	    if(!R_FINITE(rfrom))
873 
		errorcall(call, _("'%s' must be a finite number"), "from");
874 
	}
875 
	if(miss_to) rto = 1.0;
876 
	else {
71923 maechler 877 
	    if(length(to) != 1) errorcall(call, _("'%s' must be of length 1"), "to");
71917 maechler 878 
	    rto = asReal(to);
879 
	    if(!R_FINITE(rto))
880 
		errorcall(call, _("'%s' must be a finite number"), "to");
881 
	}
45446 ripley 882 
	if(by == R_MissingArg)
41715 ripley 883 
	    ans = seq_colon(rfrom, rto, call);
80483 maechler 884 
	else { // 'by' specified
71923 maechler 885 
	    if(length(by) != 1) errorcall(call, _("'%s' must be of length 1"), "by");
71917 maechler 886 
	    double del = rto - rfrom;
38997 ripley 887 
	    if(del == 0.0 && rto == 0.0) {
71917 maechler 888 
		ans = to; // is *not* missing in this case
38997 ripley 889 
		goto done;
890 
	    }
87507 maechler 891 
	    double rby = asReal(by);
892 
	    if((rby ==  1. && del > 0.) ||
893 
	       (rby == -1. && del < 0.)) { // --> treat as if missing (return integer)
894 
		ans = seq_colon(rfrom, rto, call);
895 
		goto done;
896 
	    }
87891 ripley 897 
	    bool finite_del = R_FINITE(del) != 0;
87507 maechler 898 
	    double n = (finite_del)
899 
		? del/rby
900 
		: rto/rby - rfrom/rby; /* overflow in  (to - from)  when both are finite */
38997 ripley 901 
	    if(!R_FINITE(n)) {
902 
		if(del == 0.0 && rby == 0.0) {
71917 maechler 903 
		    ans = miss_from ? ScalarReal(rfrom) : from;
38997 ripley 904 
		    goto done;
905 
		} else
71922 maechler 906 
		    errorcall(call, _("invalid '(to - from)/by'"));
38997 ripley 907 
	    }
80483 maechler 908 
	    // inherited from seq.default() but "fudgy"
909 
	    if(finite_del && fabs(del)/fmax2(fabs(rto), fabs(rfrom)) < 100 * DBL_EPSILON) {
71917 maechler 910 
		ans = miss_from ? ScalarReal(rfrom) : from;
38997 ripley 911 
		goto done;
912 
	    }
59056 ripley 913 
#ifdef LONG_VECTOR_SUPPORT
914 
	    if(n > 100 * (double) INT_MAX)
915 
#else
38997 ripley 916 
	    if(n > (double) INT_MAX)
59056 ripley 917 
#endif
38997 ripley 918 
		errorcall(call, _("'by' argument is much too small"));
50879 ripley 919 
	    if(n < - FEPS)
41715 ripley 920 
		errorcall(call, _("wrong sign in 'by' argument"));
71917 maechler 921 
 
922 
	    R_xlen_t nn;
923 
	    if((miss_from || TYPEOF(from) == INTSXP) &&
80483 maechler 924 
	       (miss_to   || TYPEOF(to)   == INTSXP) && TYPEOF(by) == INTSXP)
925 
	    {
71917 maechler 926 
		int *ia, ifrom = miss_from ? (int)rfrom : asInteger(from),
927 
		    iby = asInteger(by);
51095 ripley 928 
		/* With the current limits on integers and FEPS
929 
		   reduced below 1/INT_MAX this is the same as the
930 
		   next, so this is future-proofing against longer integers.
931 
		*/
75652 maechler 932 
		/* as seq.default also returns integer for from + (0:n)*by
51095 ripley 933 
		*/
59091 ripley 934 
		nn = (R_xlen_t) n;
50879 ripley 935 
		ans = allocVector(INTSXP, nn+1);
936 
		ia = INTEGER(ans);
937 
		for(i = 0; i <= nn; i++)
59091 ripley 938 
		    ia[i] = (int)(ifrom + i * iby);
50879 ripley 939 
	    } else {
51095 ripley 940 
		nn = (int)(n + FEPS);
50879 ripley 941 
		ans = allocVector(REALSXP, nn+1);
71917 maechler 942 
		double *ra = REAL(ans);
80483 maechler 943 
		if(finite_del)
944 
		    for(i = 0; i <= nn; i++)
945 
			ra[i] = rfrom + (double)i * rby;
946 
		else { // |from - to| is infinite, but n = (from-to)/by is not
947 
		    rfrom /= 4.;
948 
		    rby   /= 4.;
949 
		    for(i = 0; i <= nn; i++) // ldexp(Y, 2) := Y * 2^2 = 4 Y
950 
			ra[i] = ldexp(rfrom + (double)i * rby, 2);
951 
		}
50879 ripley 952 
		/* Added in 2.9.0 */
953 
		if (nn > 0)
954 
		    if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
955 
			ra[nn] = rto;
956 
	    }
38997 ripley 957 
	}
958 
    } else if (lout == 0) {
959 
	ans = allocVector(INTSXP, 0);
960 
    } else if (One) {
41715 ripley 961 
	ans = seq_colon(1.0, (double)lout, call);
80483 maechler 962 
    } else if (by == R_MissingArg) { // and  len := length.out  specified, >= 1
71917 maechler 963 
	double rfrom = asReal(from), rto = asReal(to), rby = 0; // -Wall
964 
	if(miss_to)   rto   = rfrom + (double)lout - 1;
965 
	if(miss_from) rfrom = rto   - (double)lout + 1;
966 
	if(!R_FINITE(rfrom)) errorcall(call, _("'%s' must be a finite number"), "from");
967 
	if(!R_FINITE(rto))   errorcall(call, _("'%s' must be a finite number"), "to");
87891 ripley 968 
	bool finite_del = 0;
80483 maechler 969 
	if(lout > 2) { // only then, use 'by'
970 
	    double nint = (double)(lout - 1);
87813 ripley 971 
	    if((finite_del = (R_FINITE(rby = (rto - rfrom)) != 0)))
80483 maechler 972 
		rby /= nint;
973 
	    else // overflow in (to - from), nint >= 2  => finite 'by'
974 
		rby = (rto/nint - rfrom/nint);
975 
	}
73500 ripley 976 
	if(rfrom <= INT_MAX && rfrom >= INT_MIN &&
977 
	   rto   <= INT_MAX && rto   >= INT_MIN &&
978 
	   rfrom == (int)rfrom &&
71917 maechler 979 
	   (lout <= 1 || rto == (int)rto) &&
73500 ripley 980 
	   (lout <= 2 || rby == (int)rby)) {
71917 maechler 981 
	    ans = allocVector(INTSXP, lout);
80483 maechler 982 
	    INTEGER(ans)[0] = (int)rfrom;
71926 ripley 983 
	    if(lout > 1) INTEGER(ans)[lout - 1] = (int)rto;
71917 maechler 984 
	    if(lout > 2)
985 
		for(i = 1; i < lout-1; i++) {
986 
//		    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
987 
		    INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
988 
		}
989 
	} else {
80483 maechler 990 
	    ans = allocVector(REALSXP, lout);
991 
	    REAL(ans)[0] = rfrom;
992 
	    if(lout > 1) REAL(ans)[lout - 1] = rto;
993 
	    if(lout > 2) {
994 
		if(finite_del)
995 
		    for(i = 1; i < lout-1; i++) {
996 
// 		        if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
997 
			REAL(ans)[i] = rfrom + (double)i*rby;
998 
		    }
999 
		else {  // del:=(from - to) is infinite, but n = del/by is not
1000 
		    rfrom /= 4.; // or ldexp(*, -2) for speed
1001 
		    rby   /= 4.;
1002 
		    for(i = 1; i < lout-1; i++) {
1003 
// 		        if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
1004 
			REAL(ans)[i] = ldexp(rfrom + (double)i*rby, 2); // ldexp(y,2) = y * 4
1005 
		    }
1006 
		}
60160 ripley 1007 
	    }
38997 ripley 1008 
	}
71917 maechler 1009 
    } else if (miss_to) {
38997 ripley 1010 
	double rfrom = asReal(from), rby = asReal(by), rto;
71917 maechler 1011 
	if(miss_from) rfrom = 1.0;
1012 
	if(!R_FINITE(rfrom)) errorcall(call, _("'%s' must be a finite number"), "from");
1013 
	if(!R_FINITE(rby))   errorcall(call, _("'%s' must be a finite number"), "by");
59178 ripley 1014 
	rto = rfrom + (double)(lout-1)*rby;
77956 ripley 1015 
	// avoid undefined behaviour by testing range before converting.
1016 
	if(rfrom <= INT_MAX && rfrom >= INT_MIN
1017 
	   &&  rto  <= INT_MAX &&  rto  >= INT_MIN
1018 
	   && rby == (int)rby && rfrom == (int)rfrom) {
38997 ripley 1019 
	    ans = allocVector(INTSXP, lout);
60160 ripley 1020 
	    for(i = 0; i < lout; i++) {
60336 ripley 1021 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59178 ripley 1022 
		INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
60160 ripley 1023 
	    }
38997 ripley 1024 
	} else {
1025 
	    ans = allocVector(REALSXP, lout);
60160 ripley 1026 
	    for(i = 0; i < lout; i++) {
60336 ripley 1027 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59178 ripley 1028 
		REAL(ans)[i] = rfrom + (double)i*rby;
60160 ripley 1029 
	    }
38997 ripley 1030 
	}
71917 maechler 1031 
    } else if (miss_from) {
38997 ripley 1032 
	double rto = asReal(to), rby = asReal(by),
59178 ripley 1033 
	    rfrom = rto - (double)(lout-1)*rby;
71917 maechler 1034 
	if(!R_FINITE(rto)) errorcall(call, _("'%s' must be a finite number"), "to");
1035 
	if(!R_FINITE(rby)) errorcall(call, _("'%s' must be a finite number"), "by");
75677 maechler 1036 
	if(rby == (int)rby && rto == (int)rto
1037 
	   && rfrom <= INT_MAX && rfrom >= INT_MIN
1038 
	   &&  rto  <= INT_MAX &&  rto  >= INT_MIN) {
38997 ripley 1039 
	    ans = allocVector(INTSXP, lout);
60160 ripley 1040 
	    for(i = 0; i < lout; i++) {
60336 ripley 1041 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59178 ripley 1042 
		INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
60160 ripley 1043 
	    }
38997 ripley 1044 
	} else {
1045 
	    ans = allocVector(REALSXP, lout);
60160 ripley 1046 
	    for(i = 0; i < lout; i++) {
60336 ripley 1047 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59178 ripley 1048 
		REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
60160 ripley 1049 
	    }
38997 ripley 1050 
	}
1051 
    } else
1052 
	errorcall(call, _("too many arguments"));
45446 ripley 1053 
 
38997 ripley 1054 
done:
66326 luke 1055 
    UNPROTECT(1);
38997 ripley 1056 
    return ans;
87507 maechler 1057 
} // do_seq()
39006 ripley 1058 
 
83446 ripley 1059 
attribute_hidden SEXP do_seq_along(SEXP call, SEXP op, SEXP args, SEXP rho)
39006 ripley 1060 
{
1061 
    SEXP ans;
59091 ripley 1062 
    R_xlen_t len;
54197 luke 1063 
    static SEXP length_op = NULL;
39006 ripley 1064 
 
54197 luke 1065 
    /* Store the .Primitive for 'length' for DispatchOrEval to use. */
1066 
    if (length_op == NULL) {
1067 
	SEXP R_lengthSymbol = install("length");
1068 
	length_op = eval(R_lengthSymbol, R_BaseEnv);
1069 
	if (TYPEOF(length_op) != BUILTINSXP) {
1070 
	    length_op = NULL;
1071 
	    error("'length' is not a BUILTIN");
1072 
	}
1073 
	R_PreserveObject(length_op);
1074 
    }
1075 
 
39006 ripley 1076 
    checkArity(op, args);
51267 ripley 1077 
    check1arg(args, call, "along.with");
54197 luke 1078 
 
59034 ripley 1079 
    /* Try to dispatch to S3 or S4 methods for 'length'.  For cases
54197 luke 1080 
       where no methods are defined this is more efficient than an
1081 
       unconditional callback to R */
1082 
    if (isObject(CAR(args)) &&
1083 
	DispatchOrEval(call, length_op, "length", args, rho, &ans, 0, 1)) {
48952 maechler 1084 
	len = asInteger(ans);
1085 
    }
1086 
    else
59091 ripley 1087 
	len = xlength(CAR(args));
48952 maechler 1088 
 
74244 luke 1089 
    if (len == 0)
1090 
	return allocVector(INTSXP, 0);
1091 
    else
1092 
	return R_compact_intrange(1, len);
39006 ripley 1093 
}
1094 
 
83446 ripley 1095 
attribute_hidden SEXP do_seq_len(SEXP call, SEXP op, SEXP args, SEXP rho)
39006 ripley 1096 
{
59966 ripley 1097 
    R_xlen_t len;
39006 ripley 1098 
 
1099 
    checkArity(op, args);
51267 ripley 1100 
    check1arg(args, call, "length.out");
54198 ripley 1101 
    if(length(CAR(args)) != 1)
1102 
	warningcall(call, _("first element used of '%s' argument"),
1103 
		    "length.out");
45446 ripley 1104 
 
59091 ripley 1105 
 #ifdef LONG_VECTOR_SUPPORT
59966 ripley 1106 
    double dlen = asReal(CAR(args));
1107 
    if(!R_FINITE(dlen) || dlen < 0)
1108 
	errorcall(call, _("argument must be coercible to non-negative integer"));
74888 luke 1109 
    if(dlen >= R_XLEN_T_MAX)
1110 
    	errorcall(call, _("result would be too long a vector"));
59966 ripley 1111 
    len = (R_xlen_t) dlen;
1112 
#else
1113 
    len = asInteger(CAR(args));
1114 
    if(len == NA_INTEGER || len < 0)
1115 
	errorcall(call, _("argument must be coercible to non-negative integer"));
1116 
#endif
1117 
 
74244 luke 1118 
    if (len == 0)
1119 
	return allocVector(INTSXP, 0);
1120 
    else
1121 
	return R_compact_intrange(1, len);
39006 ripley 1122 
}
77633 lawrence 1123 
 
83446 ripley 1124 
attribute_hidden SEXP do_sequence(SEXP call, SEXP op, SEXP args, SEXP rho)
77633 lawrence 1125 
{
1126 
    checkArity(op, args);
1127 
 
89122 maechler 1128 
    SEXP lengths = CAR(args);
77633 lawrence 1129 
    if (!isInteger(lengths))
88714 kalibera 1130 
	error(_("'nvec' is not of mode integer"));
89122 maechler 1131 
    SEXP from = CADR(args);
77633 lawrence 1132 
    if (!isInteger(from))
1133 
	error(_("'from' is not of mode integer"));
89122 maechler 1134 
    SEXP by = CADDR(args);
77633 lawrence 1135 
    if (!isInteger(by))
1136 
	error(_("'by' is not of mode integer"));
89122 maechler 1137 
    SEXP recycle_1st_ = CADDDR(args);
1138 
    bool maybe_warn = (bool) isInteger(recycle_1st_); // when missing(recycle) in R
1139 
    bool recycle_1st  = asBool2(recycle_1st_, call);
1140 
    R_xlen_t
1141 
	lengths_len = xlength(lengths);
1142 
    if(lengths_len == 0)
1143 
	return allocVector(INTSXP, 0);
1144 
    R_xlen_t
1145 
	from_len    = xlength(from),
1146 
	by_len      = xlength(by);
77633 lawrence 1147 
 
89122 maechler 1148 
    if (!recycle_1st && lengths_len != 0) {
77633 lawrence 1149 
	if (from_len == 0)
89122 maechler 1150 
	    error(_("'%s' has length 0, but not 'nvec'; 'recycle = TRUE' returns empty here"), "from");
77633 lawrence 1151 
	if (by_len == 0)
89122 maechler 1152 
	    error(_("'%s' has length 0, but not 'nvec'; 'recycle = TRUE' returns empty here"), "by");
1153 
    } else { // recycle_1st
1154 
	if(from_len == 0 || by_len == 0)
1155 
	return allocVector(INTSXP, 0);
77633 lawrence 1156 
    }
89122 maechler 1157 
    R_xlen_t ans_len,
1158 
	max_len = ((lengths_len > from_len) ?
1159 
		   (lengths_len > by_len ? lengths_len : by_len) :
1160 
		   (from_len    > by_len ?    from_len : by_len)),
1161 
	i, i1, i2, i3;
1162 
    if(!recycle_1st && lengths_len < max_len) {
1163 
	/* warn that this will change, if arg was missing, at most *once* per R session */
1164 
	static bool warn_1st = true;
1165 
	if(warn_1st && maybe_warn) {
1166 
	    char msg[99];
90278 jagan 1167 
	    snprintf(msg, 99, "length(nvec) = %lld < %lld = max(length(from), length(by))",
1168 
	             (long long) lengths_len, (long long) max_len);
1169 
	    warning(_("%s -- future R's default 'recycle = TRUE' will recycle 'nvec'"),
1170 
	            msg);
89122 maechler 1171 
	    warn_1st = false;
1172 
	}
1173 
	max_len = lengths_len;
1174 
    }
1175 
    const int *lengths_elt = INTEGER(lengths);
1176 
    for (i = i1 = ans_len = 0; i < max_len; i++, i1++) {
1177 
	if (i1 >= lengths_len)
1178 
	    i1 = 0; /* recycle */
1179 
	int len = lengths_elt[i1];
1180 
	if (len == NA_INTEGER || len < 0)
88714 kalibera 1181 
	    error(_("'nvec' must be a vector of non-negative integers"));
89122 maechler 1182 
	ans_len += len;
77633 lawrence 1183 
    }
89122 maechler 1184 
    SEXP ans = allocVector(INTSXP, ans_len);
1185 
    int *ans_elt = INTEGER(ans),
1186 
	*pfrom   = INTEGER(from),
1187 
	*pby     = INTEGER(by);
1188 
    for (i = i1 = i2 = i3 = 0; i < max_len; i++, i1++, i2++, i3++) {
1189 
	if (recycle_1st && i1 >= lengths_len)
1190 
	    i1 = 0; /* recycle */
77633 lawrence 1191 
	if (i2 >= from_len)
1192 
	    i2 = 0; /* recycle */
1193 
	if (i3 >= by_len)
1194 
	    i3 = 0; /* recycle */
89122 maechler 1195 
	int length = lengths_elt[i1],
1196 
	    from_elt = pfrom[i2];
88718 kalibera 1197 
	if (length != 0 && from_elt == NA_INTEGER)
77633 lawrence 1198 
	    error(_("'from' contains NAs"));
89122 maechler 1199 
	int by_elt = pby[i3];
88718 kalibera 1200 
	if (length >= 2 && by_elt == NA_INTEGER)
77633 lawrence 1201 
	    error(_("'by' contains NAs"));
77644 maechler 1202 
	// int to = from_elt + (length - 1) * by_elt;
89122 maechler 1203 
	for (int k = 0, j = from_elt; k < length; j += by_elt, k++)
77633 lawrence 1204 
	    *(ans_elt++) = j;
1205 
    }
1206 
    return ans;
1207 
}