The R Project SVN R

Rev

Rev 75677 | Rev 77644 | Go to most recent revision | 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
75652 maechler 3 
 *  Copyright (C) 1998-2018  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 */
60213 ripley 95 
#define NINTERRUPT 1000000U
60160 ripley 96 
 
41715 ripley 97 
static SEXP seq_colon(double n1, double n2, SEXP call)
4562 pd 98 
{
64275 ripley 99 
    double r = fabs(n2 - n1);
68923 ripley 100 
    if(r >= R_XLEN_T_MAX)
59451 ripley 101 
	errorcall(call, _("result would be too long a vector"));
571 ihaka 102 
 
74244 luke 103 
    if (n1 == (R_xlen_t) n1 && n2 == (R_xlen_t) n2)
74268 ripley 104 
	return R_compact_intrange((R_xlen_t) n1, (R_xlen_t) n2);
74244 luke 105 
 
64275 ripley 106 
    SEXP ans;
107 
    R_xlen_t n = (R_xlen_t)(r + 1 + FLT_EPSILON);
48823 maechler 108 
 
64275 ripley 109 
    Rboolean useInt = (n1 <= INT_MAX) &&  (n1 == (int) n1);
48823 maechler 110 
    if(useInt) {
111 
	if(n1 <= INT_MIN || n1 > INT_MAX)
112 
	    useInt = FALSE;
113 
	else {
114 
	    /* r := " the effective 'to' "  of  from:to */
59178 ripley 115 
	    double dn = (double) n;
116 
	    r = n1 + ((n1 <= n2) ? dn-1 : -(dn-1));
117 
	    if(r <= INT_MIN || r > INT_MAX) useInt = FALSE;
48823 maechler 118 
	}
119 
    }
28452 ripley 120 
    if (useInt) {
1839 ihaka 121 
	if (n1 <= n2)
74268 ripley 122 
	    ans = R_compact_intrange((R_xlen_t) n1, (R_xlen_t)(n1 + n - 1));
1839 ihaka 123 
	else
74268 ripley 124 
	    ans = R_compact_intrange((R_xlen_t) n1, (R_xlen_t)(n1 - n + 1));
1839 ihaka 125 
    } else {
126 
	ans = allocVector(REALSXP, n);
127 
	if (n1 <= n2)
60160 ripley 128 
	    for (R_xlen_t i = 0; i < n; i++) {
60336 ripley 129 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
60160 ripley 130 
		REAL(ans)[i] = n1 + (double)i;
131 
	    }
1839 ihaka 132 
	else
60160 ripley 133 
	    for (R_xlen_t i = 0; i < n; i++) {
60336 ripley 134 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
60160 ripley 135 
		REAL(ans)[i] = n1 - (double)i;
136 
	    }
1839 ihaka 137 
    }
138 
    return ans;
2 r 139 
}
140 
 
38979 ripley 141 
SEXP attribute_hidden do_colon(SEXP call, SEXP op, SEXP args, SEXP rho)
2 r 142 
{
38997 ripley 143 
    SEXP s1, s2;
144 
    double n1, n2;
45446 ripley 145 
 
1839 ihaka 146 
    checkArity(op, args);
38997 ripley 147 
    if (inherits(CAR(args), "factor") && inherits(CADR(args), "factor"))
38979 ripley 148 
	return(cross_colon(call, CAR(args), CADR(args)));
38997 ripley 149 
 
150 
    s1 = CAR(args);
151 
    s2 = CADR(args);
152 
    n1 = length(s1);
48554 maechler 153 
    n2 = length(s2);
63045 murdoch 154 
    if (n1 == 0 || n2 == 0)
155 
	errorcall(call, _("argument of length 0"));
48554 maechler 156 
    if (n1 > 1)
68923 ripley 157 
	warningcall(call,
65311 ripley 158 
		    ngettext("numerical expression has %d element: only the first used",
159 
			     "numerical expression has %d elements: only the first used",
160 
			     (int) n1), (int) n1);
48554 maechler 161 
    if (n2 > 1)
68923 ripley 162 
	warningcall(call,
163 
		    ngettext("numerical expression has %d element: only the first used",
164 
			     "numerical expression has %d elements: only the first used",
65311 ripley 165 
			     (int) n2), (int) n2);
38997 ripley 166 
    n1 = asReal(s1);
167 
    n2 = asReal(s2);
168 
    if (ISNAN(n1) || ISNAN(n2))
169 
	errorcall(call, _("NA/NaN argument"));
41715 ripley 170 
    return seq_colon(n1, n2, call);
2 r 171 
}
172 
 
59900 ripley 173 
/* rep.int(x, times) for a vector times */
2 r 174 
static SEXP rep2(SEXP s, SEXP ncopy)
175 
{
71914 maechler 176 
    R_xlen_t i, j, nc, n;
59895 ripley 177 
    SEXP a, t;
2 r 178 
 
71922 maechler 179 
#define R2_SWITCH_LOOP(it) \
71914 maechler 180 
    switch (TYPEOF(s)) { \
181 
    case LGLSXP: \
182 
	for (i = 0; i < nc; i++) { \
183 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
184 
	    for (j = 0; j < (R_xlen_t) it[i]; j++) \
185 
		LOGICAL(a)[n++] = LOGICAL(s)[i]; \
186 
	} \
187 
	break; \
188 
    case INTSXP: \
189 
	for (i = 0; i < nc; i++) { \
190 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 191 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 192 
		INTEGER(a)[n++] = INTEGER(s)[i]; \
193 
	} \
194 
	break; \
195 
    case REALSXP: \
196 
	for (i = 0; i < nc; i++) { \
197 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 198 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 199 
		REAL(a)[n++] = REAL(s)[i]; \
200 
	} \
201 
	break; \
202 
    case CPLXSXP: \
203 
	for (i = 0; i < nc; i++) { \
204 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 205 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 206 
		COMPLEX(a)[n++] = COMPLEX(s)[i]; \
207 
	} \
208 
	break; \
209 
    case STRSXP: \
210 
	for (i = 0; i < nc; i++) { \
211 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 212 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 213 
		SET_STRING_ELT(a, n++, STRING_ELT(s, i)); \
214 
	} \
215 
	break; \
216 
    case VECSXP: \
217 
    case EXPRSXP: \
218 
	for (i = 0; i < nc; i++) { \
219 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
220 
	    SEXP elt = lazy_duplicate(VECTOR_ELT(s, i)); \
71996 maechler 221 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 222 
		SET_VECTOR_ELT(a, n++, elt); \
73166 luke 223 
	    if (j > 1) ENSURE_NAMEDMAX(elt); \
71914 maechler 224 
	} \
225 
	break; \
226 
    case RAWSXP: \
227 
	for (i = 0; i < nc; i++) { \
228 
/*	    if ((i+1) % ni == 0) R_CheckUserInterrupt();*/ \
71996 maechler 229 
	    for (j = (R_xlen_t) it[i]; j > 0; j--) \
71914 maechler 230 
		RAW(a)[n++] = RAW(s)[i]; \
231 
	} \
232 
	break; \
233 
    default: \
234 
	UNIMPLEMENTED_TYPE("rep2", s); \
235 
    }
236 
 
237 
#ifdef LONG_VECTOR_SUPPORT
238 
    if (TYPEOF(ncopy) != INTSXP)
239 
#else
240 
    if (TYPEOF(ncopy) == REALSXP)
241 
#endif
72292 ripley 242 
	PROTECT(t = coerceVector(ncopy, REALSXP));
71914 maechler 243 
    else
72292 ripley 244 
	PROTECT(t = coerceVector(ncopy, INTSXP));
2 r 245 
 
59052 ripley 246 
    nc = xlength(ncopy);
71914 maechler 247 
    double sna = 0;
248 
    if (TYPEOF(t) == REALSXP)
1839 ihaka 249 
    for (i = 0; i < nc; i++) {
60336 ripley 250 
//	if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
71914 maechler 251 
	if (ISNAN(REAL(t)[i]) || REAL(t)[i] <= -1 ||
252 
	    REAL(t)[i] >= R_XLEN_T_MAX+1.0)
253 
	    error(_("invalid '%s' value"), "times");
254 
	sna += (R_xlen_t) REAL(t)[i];
255 
    }
256 
    else
257 
    for (i = 0; i < nc; i++) {
258 
//	if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59892 ripley 259 
	if (INTEGER(t)[i] == NA_INTEGER || INTEGER(t)[i] < 0)
41715 ripley 260 
	    error(_("invalid '%s' value"), "times");
71914 maechler 261 
	sna += INTEGER(t)[i];
1839 ihaka 262 
    }
71914 maechler 263 
    if (sna > R_XLEN_T_MAX)
264 
	error(_("invalid '%s' value"), "times");
265 
    R_xlen_t na = (R_xlen_t) sna;
2 r 266 
 
60336 ripley 267 
/*    R_xlen_t ni = NINTERRUPT, ratio;
60213 ripley 268 
    if(nc > 0) {
269 
	ratio = na/nc; // average no of replications
270 
	if (ratio > 1000U) ni = 1000U;
60336 ripley 271 
	} */
59895 ripley 272 
    PROTECT(a = allocVector(TYPEOF(s), na));
1839 ihaka 273 
    n = 0;
71922 maechler 274 
    if (TYPEOF(t) == REALSXP)
275 
	R2_SWITCH_LOOP(REAL(t))
276 
    else
277 
	R2_SWITCH_LOOP(INTEGER(t))
1839 ihaka 278 
    UNPROTECT(2);
279 
    return a;
2 r 280 
}
71914 maechler 281 
#undef R2_SWITCH_LOOP
2 r 282 
 
59900 ripley 283 
/* rep_len(x, len), also used for rep.int() with scalar 'times' */
59918 ripley 284 
static SEXP rep3(SEXP s, R_xlen_t ns, R_xlen_t na)
2 r 285 
{
59918 ripley 286 
    R_xlen_t i, j;
59892 ripley 287 
    SEXP a;
2 r 288 
 
59895 ripley 289 
    PROTECT(a = allocVector(TYPEOF(s), na));
2 r 290 
 
59909 ripley 291 
    switch (TYPEOF(s)) {
292 
    case LGLSXP:
68663 luke 293 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 294 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 295 
	    LOGICAL(a)[i] = LOGICAL(s)[j];
296 
	});
59909 ripley 297 
	break;
298 
    case INTSXP:
68663 luke 299 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 300 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 301 
	    INTEGER(a)[i] = INTEGER(s)[j];
302 
	});
59909 ripley 303 
	break;
304 
    case REALSXP:
68663 luke 305 
	MOD_ITERATE1(na, ns, i, j,  {
60336 ripley 306 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 307 
	    REAL(a)[i] = REAL(s)[j];
308 
	});
59909 ripley 309 
	break;
310 
    case CPLXSXP:
68663 luke 311 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 312 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 313 
	    COMPLEX(a)[i] = COMPLEX(s)[j];
314 
	});
59909 ripley 315 
	break;
316 
    case RAWSXP:
68663 luke 317 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 318 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 319 
	    RAW(a)[i] = RAW(s)[j];
320 
	});
59909 ripley 321 
	break;
322 
    case STRSXP:
68663 luke 323 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 324 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 325 
	    SET_STRING_ELT(a, i, STRING_ELT(s, j));
326 
	});
59909 ripley 327 
	break;
328 
    case VECSXP:
59921 ripley 329 
    case EXPRSXP:
68663 luke 330 
	MOD_ITERATE1(na, ns, i, j, {
60336 ripley 331 
//	    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
68663 luke 332 
	    SET_VECTOR_ELT(a, i, lazy_duplicate(VECTOR_ELT(s, j)));
333 
	});
59909 ripley 334 
	break;
335 
    default:
336 
	UNIMPLEMENTED_TYPE("rep3", s);
59885 ripley 337 
    }
59895 ripley 338 
    UNPROTECT(1);
59892 ripley 339 
    return a;
340 
}
341 
 
72271 maechler 342 
// .Internal(rep.int(x, times))
59892 ripley 343 
SEXP attribute_hidden do_rep_int(SEXP call, SEXP op, SEXP args, SEXP rho)
344 
{
345 
    checkArity(op, args);
346 
    SEXP s = CAR(args), ncopy = CADR(args);
347 
    R_xlen_t nc;
348 
    SEXP a;
349 
 
74659 lawrence 350 
    if (DispatchOrEval(call, op, "rep.int", args, rho, &a, 0, 0))
351 
      return(a);
352 
 
59892 ripley 353 
    if (!isVector(ncopy))
72271 maechler 354 
	error(_("invalid type (%s) for '%s' (must be a vector)"),
355 
	      type2char(TYPEOF(ncopy)), "times");
59892 ripley 356 
 
59895 ripley 357 
    if (!isVector(s) && s != R_NilValue)
68923 ripley 358 
	error(_("attempt to replicate an object of type '%s'"),
59921 ripley 359 
	      type2char(TYPEOF(s)));
59892 ripley 360 
 
361 
    nc = xlength(ncopy); // might be 0
72271 maechler 362 
    if (nc == xlength(s))
59909 ripley 363 
	PROTECT(a = rep2(s, ncopy));
59892 ripley 364 
    else {
365 
	if (nc != 1) error(_("invalid '%s' value"), "times");
68923 ripley 366 
 
71914 maechler 367 
	R_xlen_t ns = xlength(s);
368 
	if (TYPEOF(ncopy) != INTSXP) {
72292 ripley 369 
	    double snc = asReal(ncopy);
370 
	    if (!R_FINITE(snc) || snc <= -1. ||
371 
		(ns > 0 && snc >= R_XLEN_T_MAX + 1.))
372 
		error(_("invalid '%s' value"), "times");
373 
	    nc = ns == 0 ? 1 : (R_xlen_t) snc;
374 
	} else if ((nc = asInteger(ncopy)) == NA_INTEGER || nc < 0) // nc = 0 ok
59892 ripley 375 
	    error(_("invalid '%s' value"), "times");
71914 maechler 376 
	if ((double) nc * ns > R_XLEN_T_MAX)
377 
	    error(_("invalid '%s' value"), "times");
59918 ripley 378 
	PROTECT(a = rep3(s, ns, nc * ns));
59892 ripley 379 
    }
380 
 
381 
#ifdef _S4_rep_keepClass
382 
    if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
383 
	setAttrib(a, R_ClassSymbol, getAttrib(s, R_ClassSymbol));
384 
	SET_S4_OBJECT(a);
385 
    }
386 
#endif
387 
 
59885 ripley 388 
    if (inherits(s, "factor")) {
389 
	SEXP tmp;
390 
	if(inherits(s, "ordered")) {
391 
	    PROTECT(tmp = allocVector(STRSXP, 2));
392 
	    SET_STRING_ELT(tmp, 0, mkChar("ordered"));
393 
	    SET_STRING_ELT(tmp, 1, mkChar("factor"));
394 
	} else PROTECT(tmp = mkString("factor"));
395 
	setAttrib(a, R_ClassSymbol, tmp);
396 
	UNPROTECT(1);
397 
	setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
398 
    }
399 
    UNPROTECT(1);
400 
    return a;
401 
}
402 
 
59892 ripley 403 
SEXP attribute_hidden do_rep_len(SEXP call, SEXP op, SEXP args, SEXP rho)
404 
{
59918 ripley 405 
    R_xlen_t ns, na;
59892 ripley 406 
    SEXP a, s, len;
59885 ripley 407 
 
59892 ripley 408 
    checkArity(op, args);
74659 lawrence 409 
 
410 
    if (DispatchOrEval(call, op, "rep_len", args, rho, &a, 0, 0))
411 
      return(a);
412 
 
59892 ripley 413 
    s = CAR(args);
414 
 
59895 ripley 415 
    if (!isVector(s) && s != R_NilValue)
59892 ripley 416 
	error(_("attempt to replicate non-vector"));
417 
 
418 
    len = CADR(args);
419 
    if(length(len) != 1)
420 
	error(_("invalid '%s' value"), "length.out");
71914 maechler 421 
    if (TYPEOF(len) != INTSXP) {
72292 ripley 422 
	double sna = asReal(len);
423 
	if (ISNAN(sna) || sna <= -1. || sna >= R_XLEN_T_MAX + 1.)
424 
	    error(_("invalid '%s' value"), "length.out");
425 
	na = (R_xlen_t) sna;
71914 maechler 426 
    } else
72292 ripley 427 
	if ((na = asInteger(len)) == NA_INTEGER || na < 0) /* na = 0 ok */
428 
	    error(_("invalid '%s' value"), "length.out");
59892 ripley 429 
 
59909 ripley 430 
    if (TYPEOF(s) == NILSXP && na > 0)
431 
	error(_("cannot replicate NULL to a non-zero length"));
59918 ripley 432 
    ns = xlength(s);
433 
    if (ns == 0) {
59909 ripley 434 
	SEXP a;
435 
	PROTECT(a = duplicate(s));
436 
	if(na > 0) a = xlengthgets(a, na);
437 
	UNPROTECT(1);
438 
	return a;
439 
    }
59918 ripley 440 
    PROTECT(a = rep3(s, ns, na));
59892 ripley 441 
 
442 
#ifdef _S4_rep_keepClass
443 
    if(IS_S4_OBJECT(s)) { /* e.g. contains = "list" */
444 
	setAttrib(a, R_ClassSymbol, getAttrib(s, R_ClassSymbol));
445 
	SET_S4_OBJECT(a);
446 
    }
447 
#endif
448 
 
449 
    if (inherits(s, "factor")) {
450 
	SEXP tmp;
451 
	if(inherits(s, "ordered")) {
452 
	    PROTECT(tmp = allocVector(STRSXP, 2));
453 
	    SET_STRING_ELT(tmp, 0, mkChar("ordered"));
454 
	    SET_STRING_ELT(tmp, 1, mkChar("factor"));
455 
	} else PROTECT(tmp = mkString("factor"));
456 
	setAttrib(a, R_ClassSymbol, tmp);
457 
	UNPROTECT(1);
458 
	setAttrib(a, R_LevelsSymbol, getAttrib(s, R_LevelsSymbol));
459 
    }
460 
    UNPROTECT(1);
461 
    return a;
462 
}
463 
 
71611 maechler 464 
/* rep(), allowing for both times and each ;
465 
 * -----  nt == length(times) ;  if (nt == 1)  'times' is *not* accessed  */
71914 maechler 466 
static SEXP rep4(SEXP x, SEXP times, R_xlen_t len, R_xlen_t each, R_xlen_t nt)
59900 ripley 467 
{
468 
    SEXP a;
469 
    R_xlen_t lx = xlength(x);
470 
    R_xlen_t i, j, k, k2, k3, sum;
59918 ripley 471 
 
472 
    // faster code for common special case
473 
    if (each == 1 && nt == 1) return rep3(x, lx, len);
474 
 
59900 ripley 475 
    PROTECT(a = allocVector(TYPEOF(x), len));
476 
 
72292 ripley 477 
#define R4_SWITCH_LOOP(itimes)						\
478 
    switch (TYPEOF(x)) {						\
479 
    case LGLSXP:							\
480 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
481 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
482 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
483 
	    for(k3 = 0; k3 < sum; k3++) {				\
484 
		LOGICAL(a)[k2++] = LOGICAL(x)[i];			\
485 
		if(k2 == len) goto done;				\
486 
	    }								\
487 
	}								\
488 
	break;								\
489 
    case INTSXP:							\
490 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
491 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
492 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
493 
	    for(k3 = 0; k3 < sum; k3++) {				\
494 
		INTEGER(a)[k2++] = INTEGER(x)[i];			\
495 
		if(k2 == len) goto done;				\
496 
	    }								\
497 
	}								\
498 
	break;								\
499 
    case REALSXP:							\
500 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
501 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
502 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
503 
	    for(k3 = 0; k3 < sum; k3++) {				\
504 
		REAL(a)[k2++] = REAL(x)[i];				\
505 
		if(k2 == len) goto done;				\
506 
	    }								\
507 
	}								\
508 
	break;								\
509 
    case CPLXSXP:							\
510 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
511 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
512 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
513 
	    for(k3 = 0; k3 < sum; k3++) {				\
514 
		COMPLEX(a)[k2++] = COMPLEX(x)[i];			\
515 
		if(k2 == len) goto done;				\
516 
	    }								\
517 
	}								\
518 
	break;								\
519 
    case STRSXP:							\
520 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
521 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
522 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
523 
	    for(k3 = 0; k3 < sum; k3++) {				\
524 
		SET_STRING_ELT(a, k2++, STRING_ELT(x, i));		\
525 
		if(k2 == len) goto done;				\
526 
	    }								\
527 
	}								\
528 
	break;								\
529 
    case VECSXP:							\
530 
    case EXPRSXP:							\
531 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
532 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
533 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
534 
	    for(k3 = 0; k3 < sum; k3++) {				\
535 
		SET_VECTOR_ELT(a, k2++, VECTOR_ELT(x, i));		\
536 
		if(k2 == len) goto done;				\
537 
	    }								\
538 
	}								\
539 
	break;								\
540 
    case RAWSXP:							\
541 
	for(i = 0, k = 0, k2 = 0; i < lx; i++) {			\
542 
	    /*		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();*/ \
543 
	    for(j = 0, sum = 0; j < each; j++) sum += (R_xlen_t) itimes[k++]; \
544 
	    for(k3 = 0; k3 < sum; k3++) {				\
545 
		RAW(a)[k2++] = RAW(x)[i];				\
546 
		if(k2 == len) goto done;				\
547 
	    }								\
548 
	}								\
549 
	break;								\
550 
    default:								\
551 
	UNIMPLEMENTED_TYPE("rep4", x);					\
71914 maechler 552 
    }
553 
 
554 
    if(nt == 1)
72292 ripley 555 
	switch (TYPEOF(x)) {
556 
	case LGLSXP:
60160 ripley 557 
	    for(i = 0; i < len; i++) {
60336 ripley 558 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 559 
		LOGICAL(a)[i] = LOGICAL(x)[(i/each) % lx];
60160 ripley 560 
	    }
72292 ripley 561 
	    break;
562 
	case INTSXP:
60160 ripley 563 
	    for(i = 0; i < len; i++) {
60336 ripley 564 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 565 
		INTEGER(a)[i] = INTEGER(x)[(i/each) % lx];
60160 ripley 566 
	    }
72292 ripley 567 
	    break;
568 
	case REALSXP:
60160 ripley 569 
	    for(i = 0; i < len; i++) {
60336 ripley 570 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 571 
		REAL(a)[i] = REAL(x)[(i/each) % lx];
60160 ripley 572 
	    }
72292 ripley 573 
	    break;
574 
	case CPLXSXP:
60160 ripley 575 
	    for(i = 0; i < len; i++) {
60336 ripley 576 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 577 
		COMPLEX(a)[i] = COMPLEX(x)[(i/each) % lx];
60160 ripley 578 
	    }
72292 ripley 579 
	    break;
580 
	case STRSXP:
60160 ripley 581 
	    for(i = 0; i < len; i++) {
60336 ripley 582 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 583 
		SET_STRING_ELT(a, i, STRING_ELT(x, (i/each) % lx));
60160 ripley 584 
	    }
72292 ripley 585 
	    break;
586 
	case VECSXP:
587 
	case EXPRSXP:
60160 ripley 588 
	    for(i = 0; i < len; i++) {
60336 ripley 589 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 590 
		SET_VECTOR_ELT(a, i, VECTOR_ELT(x, (i/each) % lx));
60160 ripley 591 
	    }
72292 ripley 592 
	    break;
593 
	case RAWSXP:
60160 ripley 594 
	    for(i = 0; i < len; i++) {
60336 ripley 595 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59900 ripley 596 
		RAW(a)[i] = RAW(x)[(i/each) % lx];
60160 ripley 597 
	    }
72292 ripley 598 
	    break;
599 
	default:
600 
	    UNIMPLEMENTED_TYPE("rep4", x);
601 
	}
71922 maechler 602 
    else if(TYPEOF(times) == REALSXP)
603 
	R4_SWITCH_LOOP(REAL(times))
72292 ripley 604 
	else
605 
	    R4_SWITCH_LOOP(INTEGER(times))
606 
		done:
607 
	    UNPROTECT(1);
59900 ripley 608 
    return a;
609 
}
71914 maechler 610 
#undef R4_SWITCH_LOOP
59900 ripley 611 
 
38997 ripley 612 
/* We are careful to use evalListKeepMissing here (inside
613 
   DispatchOrEval) to avoid dropping missing arguments so e.g.
614 
   rep(1:3,,8) matches length.out */
51245 ripley 615 
 
616 
/* This is a primitive SPECIALSXP with internal argument matching */
38994 ripley 617 
SEXP attribute_hidden do_rep(SEXP call, SEXP op, SEXP args, SEXP rho)
618 
{
71611 maechler 619 
    SEXP ans, x, times = R_NilValue;
71914 maechler 620 
    R_xlen_t i, lx, len = NA_INTEGER, each = 1, nt;
66326 luke 621 
    static SEXP do_rep_formals = NULL;
38994 ripley 622 
 
59900 ripley 623 
    /* includes factors, POSIX[cl]t, Date */
40093 ripley 624 
    if (DispatchOrEval(call, op, "rep", args, rho, &ans, 0, 0))
40056 ripley 625 
	return(ans);
40093 ripley 626 
 
38997 ripley 627 
    /* This has evaluated all the non-missing arguments into ans */
628 
    PROTECT(args = ans);
38994 ripley 629 
 
38997 ripley 630 
    /* This is a primitive, and we have not dispatched to a method
38994 ripley 631 
       so we manage the argument matching ourselves.  We pretend this is
632 
       rep(x, times, length.out, each, ...)
633 
    */
66326 luke 634 
    if (do_rep_formals == NULL)
68923 ripley 635 
	do_rep_formals = allocFormalsList5(install("x"), install("times"),
66326 luke 636 
					   install("length.out"),
637 
					   install("each"), R_DotsSymbol);
77452 luke 638 
    PROTECT(args = matchArgs_NR(do_rep_formals, args, call));
38994 ripley 639 
 
45446 ripley 640 
    x = CAR(args);
61272 ripley 641 
    /* supported in R 2.15.x */
59900 ripley 642 
    if (TYPEOF(x) == LISTSXP)
643 
	errorcall(call, "replication of pairlists is defunct");
644 
 
59056 ripley 645 
    lx = xlength(x);
38994 ripley 646 
 
71914 maechler 647 
    if (TYPEOF(CADDR(args)) != INTSXP) {
72292 ripley 648 
	double slen = asReal(CADDR(args));
649 
	if (R_FINITE(slen)) {
650 
	    if (slen <= -1 || slen >= R_XLEN_T_MAX+1.0)
651 
		errorcall(call, _("invalid '%s' argument"), "length.out");
652 
	    len = (R_xlen_t) slen;
653 
	} else
654 
	    len = NA_INTEGER;
59056 ripley 655 
    } else {
656 
	len = asInteger(CADDR(args));
657 
	if(len != NA_INTEGER && len < 0)
658 
	    errorcall(call, _("invalid '%s' argument"), "length.out");
659 
    }
54198 ripley 660 
    if(length(CADDR(args)) != 1)
68923 ripley 661 
	warningcall(call, _("first element used of '%s' argument"),
54198 ripley 662 
		    "length.out");
38994 ripley 663 
 
71914 maechler 664 
    if (TYPEOF(CADDDR(args)) != INTSXP) {
665 
	double seach = asReal(CADDDR(args));
666 
	if (R_FINITE(seach)) {
72292 ripley 667 
	    if (seach <= -1. || (lx > 0 && seach >= R_XLEN_T_MAX + 1.))
71914 maechler 668 
		errorcall(call, _("invalid '%s' argument"), "each");
669 
	    each = lx == 0 ? NA_INTEGER : (R_xlen_t) seach;
670 
	} else each = NA_INTEGER;
671 
    } else {
72292 ripley 672 
	each = asInteger(CADDDR(args));
673 
	if(each != NA_INTEGER && each < 0)
674 
	    errorcall(call, _("invalid '%s' argument"), "each");
71914 maechler 675 
    }
54198 ripley 676 
    if(length(CADDDR(args)) != 1)
677 
	warningcall(call, _("first element used of '%s' argument"), "each");
38994 ripley 678 
    if(each == NA_INTEGER) each = 1;
679 
 
680 
    if(lx == 0) {
68923 ripley 681 
	if(len > 0 && x == R_NilValue)
59890 ripley 682 
	    warningcall(call, "'x' is NULL so the result will be NULL");
59885 ripley 683 
	SEXP a;
684 
	PROTECT(a = duplicate(x));
72979 maechler 685 
	if(len != NA_INTEGER && len > 0 && x != R_NilValue)
686 
	    a = xlengthgets(a, len);
66326 luke 687 
	UNPROTECT(3);
59885 ripley 688 
	return a;
38994 ripley 689 
    }
59966 ripley 690 
    if (!isVector(x))
691 
	errorcall(call, "attempt to replicate an object of type '%s'",
692 
		  type2char(TYPEOF(x)));
38994 ripley 693 
 
59900 ripley 694 
    /* So now we know x is a vector of positive length.  We need to
695 
       replicate it, and its names if it has them. */
696 
 
71914 maechler 697 
    int nprotect = 2;
59900 ripley 698 
    /* First find the final length using 'times' and 'each' */
38994 ripley 699 
    if(len != NA_INTEGER) { /* takes precedence over times */
700 
	nt = 1;
701 
    } else {
71914 maechler 702 
	double sum = 0;
703 
	if(CADR(args) == R_MissingArg)
704 
	    PROTECT(times = ScalarInteger(1));
705 
#ifdef LONG_VECTOR_SUPPORT
706 
	else if(TYPEOF(CADR(args)) != INTSXP)
707 
#else
708 
	else if(TYPEOF(CADR(args)) == REALSXP)
709 
#endif
710 
	    PROTECT(times = coerceVector(CADR(args), REALSXP));
711 
	else PROTECT(times = coerceVector(CADR(args), INTSXP));
712 
	nprotect++;
713 
	nt = XLENGTH(times);
39848 ripley 714 
	if(nt == 1) {
71611 maechler 715 
	    R_xlen_t it;
71914 maechler 716 
	    if (TYPEOF(times) == REALSXP) {
717 
		double rt = REAL(times)[0];
718 
		if (ISNAN(rt) || rt <= -1 || rt >= R_XLEN_T_MAX+1.0)
71636 maechler 719 
		    errorcall(call, _("invalid '%s' argument"), "times");
720 
		it = (R_xlen_t) rt;
71914 maechler 721 
	    } else {
722 
		it = INTEGER(times)[0];
71636 maechler 723 
		if (it == NA_INTEGER || it < 0)
724 
		    errorcall(call, _("invalid '%s' argument"), "times");
71611 maechler 725 
	    }
71914 maechler 726 
	    if ((double) lx * it * each > R_XLEN_T_MAX)
727 
		errorcall(call, _("invalid '%s' argument"), "times");
50305 falcon 728 
	    len = lx * it * each;
71914 maechler 729 
	} else { // nt != 1
730 
	    if(nt != (double) lx * each)
71611 maechler 731 
		errorcall(call, _("invalid '%s' argument"), "times");
71914 maechler 732 
	    if (TYPEOF(times) == REALSXP)
72292 ripley 733 
		for(i = 0; i < nt; i++) {
734 
		    double rt = REAL(times)[i];
735 
		    if (ISNAN(rt) || rt <= -1 || rt >= R_XLEN_T_MAX+1.0)
736 
			errorcall(call, _("invalid '%s' argument"), "times");
737 
		    sum += (R_xlen_t) rt;
738 
		}
71914 maechler 739 
	    else
72292 ripley 740 
		for(i = 0; i < nt; i++) {
741 
		    int it = INTEGER(times)[i];
742 
		    if (it == NA_INTEGER || it < 0)
743 
			errorcall(call, _("invalid '%s' argument"), "times");
744 
		    sum += it;
745 
		}
71914 maechler 746 
	    if (sum > R_XLEN_T_MAX)
747 
		errorcall(call, _("invalid '%s' argument"), "times");
748 
	    len = (R_xlen_t) sum;
38994 ripley 749 
	}
750 
    }
59900 ripley 751 
 
40984 ripley 752 
    if(len > 0 && each == 0)
753 
	errorcall(call, _("invalid '%s' argument"), "each");
59900 ripley 754 
 
71914 maechler 755 
    SEXP xn = PROTECT(getAttrib(x, R_NamesSymbol));  nprotect++;
756 
    PROTECT(ans = rep4(x, times, len, each, nt));    nprotect++;
757 
 
758 
    if (xlength(xn) > 0)
59900 ripley 759 
	setAttrib(ans, R_NamesSymbol, rep4(xn, times, len, each, nt));
760 
 
48206 maechler 761 
#ifdef _S4_rep_keepClass
47083 maechler 762 
    if(IS_S4_OBJECT(x)) { /* e.g. contains = "list" */
763 
	setAttrib(ans, R_ClassSymbol, getAttrib(x, R_ClassSymbol));
764 
	SET_S4_OBJECT(ans);
765 
    }
48206 maechler 766 
#endif
38994 ripley 767 
    UNPROTECT(nprotect);
768 
    return ans;
769 
}
38997 ripley 770 
 
771 
 
45446 ripley 772 
/*
51245 ripley 773 
  This is a primitive SPECIALSXP with internal argument matching,
71917 maechler 774 
  implementing seq.int().
51245 ripley 775 
 
38997 ripley 776 
   'along' has to be used on an unevaluated argument, and evalList
777 
   tries to evaluate language objects.
778 
 */
51095 ripley 779 
#define FEPS 1e-10
50879 ripley 780 
/* to match seq.default */
38997 ripley 781 
SEXP attribute_hidden do_seq(SEXP call, SEXP op, SEXP args, SEXP rho)
782 
{
66326 luke 783 
    SEXP ans = R_NilValue /* -Wall */, from, to, by, len, along;
59056 ripley 784 
    int nargs = length(args), lf;
71917 maechler 785 
    Rboolean One = (nargs == 1);
59056 ripley 786 
    R_xlen_t i, lout = NA_INTEGER;
66326 luke 787 
    static SEXP do_seq_formals = NULL;
38997 ripley 788 
 
53179 ripley 789 
    if (DispatchOrEval(call, op, "seq", args, rho, &ans, 0, 1))
40056 ripley 790 
	return(ans);
38997 ripley 791 
 
53179 ripley 792 
    /* This is a primitive and we manage argument matching ourselves.
793 
       We pretend this is
38997 ripley 794 
       seq(from, to, by, length.out, along.with, ...)
795 
    */
66326 luke 796 
    if (do_seq_formals == NULL)
68923 ripley 797 
	do_seq_formals = allocFormalsList6(install("from"), install("to"),
66326 luke 798 
					   install("by"), install("length.out"),
799 
					   install("along.with"), R_DotsSymbol);
77452 luke 800 
    PROTECT(args = matchArgs_NR(do_seq_formals, args, call));
38997 ripley 801 
 
802 
    from = CAR(args); args = CDR(args);
71917 maechler 803 
    to   = CAR(args); args = CDR(args);
804 
    by   = CAR(args); args = CDR(args);
805 
    len  = CAR(args); args = CDR(args);
806 
    along= CAR(args);
807 
    Rboolean
808 
	miss_from = (from == R_MissingArg),
809 
	miss_to   = (to   == R_MissingArg);
38997 ripley 810 
 
71917 maechler 811 
    if(One && !miss_from) {
38997 ripley 812 
	lf = length(from);
63303 ripley 813 
	if(lf == 1 && (TYPEOF(from) == INTSXP || TYPEOF(from) == REALSXP)) {
814 
	    double rfrom = asReal(from);
815 
	    if (!R_FINITE(rfrom))
71917 maechler 816 
		errorcall(call, _("'%s' must be a finite number"), "from");
63303 ripley 817 
	    ans = seq_colon(1.0, rfrom, call);
818 
	}
38997 ripley 819 
	else if (lf)
41715 ripley 820 
	    ans = seq_colon(1.0, (double)lf, call);
38997 ripley 821 
	else
822 
	    ans = allocVector(INTSXP, 0);
823 
	goto done;
824 
    }
825 
    if(along != R_MissingArg) {
59056 ripley 826 
	lout = XLENGTH(along);
38997 ripley 827 
	if(One) {
41715 ripley 828 
	    ans = lout ? seq_colon(1.0, (double)lout, call) : allocVector(INTSXP, 0);
38997 ripley 829 
	    goto done;
830 
	}
831 
    } else if(len != R_MissingArg && len != R_NilValue) {
832 
	double rout = asReal(len);
833 
	if(ISNAN(rout) || rout <= -0.5)
834 
	    errorcall(call, _("'length.out' must be a non-negative number"));
54198 ripley 835 
	if(length(len) != 1)
68923 ripley 836 
	    warningcall(call, _("first element used of '%s' argument"),
54198 ripley 837 
			"length.out");
59056 ripley 838 
	lout = (R_xlen_t) ceil(rout);
38997 ripley 839 
    }
840 
 
841 
    if(lout == NA_INTEGER) {
71917 maechler 842 
	double rfrom, rto, rby = asReal(by);
843 
	if(miss_from) rfrom = 1.0;
844 
	else {
71923 maechler 845 
	    if(length(from) != 1) errorcall(call, _("'%s' must be of length 1"), "from");
71917 maechler 846 
	    rfrom = asReal(from);
847 
	    if(!R_FINITE(rfrom))
848 
		errorcall(call, _("'%s' must be a finite number"), "from");
849 
	}
850 
	if(miss_to) rto = 1.0;
851 
	else {
71923 maechler 852 
	    if(length(to) != 1) errorcall(call, _("'%s' must be of length 1"), "to");
71917 maechler 853 
	    rto = asReal(to);
854 
	    if(!R_FINITE(rto))
855 
		errorcall(call, _("'%s' must be a finite number"), "to");
856 
	}
45446 ripley 857 
	if(by == R_MissingArg)
41715 ripley 858 
	    ans = seq_colon(rfrom, rto, call);
38997 ripley 859 
	else {
71923 maechler 860 
	    if(length(by) != 1) errorcall(call, _("'%s' must be of length 1"), "by");
71917 maechler 861 
	    double del = rto - rfrom;
38997 ripley 862 
	    if(del == 0.0 && rto == 0.0) {
71917 maechler 863 
		ans = to; // is *not* missing in this case
38997 ripley 864 
		goto done;
865 
	    }
866 
	    /* printf("from = %f, to = %f, by = %f\n", rfrom, rto, rby); */
71917 maechler 867 
	    double n = del/rby;
38997 ripley 868 
	    if(!R_FINITE(n)) {
869 
		if(del == 0.0 && rby == 0.0) {
71917 maechler 870 
		    ans = miss_from ? ScalarReal(rfrom) : from;
38997 ripley 871 
		    goto done;
872 
		} else
71922 maechler 873 
		    errorcall(call, _("invalid '(to - from)/by'"));
38997 ripley 874 
	    }
71917 maechler 875 
	    double dd = fabs(del)/fmax2(fabs(rto), fabs(rfrom));
38997 ripley 876 
	    if(dd < 100 * DBL_EPSILON) {
71917 maechler 877 
		ans = miss_from ? ScalarReal(rfrom) : from;
38997 ripley 878 
		goto done;
879 
	    }
59056 ripley 880 
#ifdef LONG_VECTOR_SUPPORT
881 
	    if(n > 100 * (double) INT_MAX)
882 
#else
38997 ripley 883 
	    if(n > (double) INT_MAX)
59056 ripley 884 
#endif
38997 ripley 885 
		errorcall(call, _("'by' argument is much too small"));
50879 ripley 886 
	    if(n < - FEPS)
41715 ripley 887 
		errorcall(call, _("wrong sign in 'by' argument"));
71917 maechler 888 
 
889 
	    R_xlen_t nn;
890 
	    if((miss_from || TYPEOF(from) == INTSXP) &&
891 
	       (miss_to   || TYPEOF(to)   == INTSXP) &&
50879 ripley 892 
	       TYPEOF(by) == INTSXP) {
71917 maechler 893 
		int *ia, ifrom = miss_from ? (int)rfrom : asInteger(from),
894 
		    iby = asInteger(by);
51095 ripley 895 
		/* With the current limits on integers and FEPS
896 
		   reduced below 1/INT_MAX this is the same as the
897 
		   next, so this is future-proofing against longer integers.
898 
		*/
75652 maechler 899 
		/* as seq.default also returns integer for from + (0:n)*by
51095 ripley 900 
		*/
59091 ripley 901 
		nn = (R_xlen_t) n;
50879 ripley 902 
		ans = allocVector(INTSXP, nn+1);
903 
		ia = INTEGER(ans);
904 
		for(i = 0; i <= nn; i++)
59091 ripley 905 
		    ia[i] = (int)(ifrom + i * iby);
50879 ripley 906 
	    } else {
51095 ripley 907 
		nn = (int)(n + FEPS);
50879 ripley 908 
		ans = allocVector(REALSXP, nn+1);
71917 maechler 909 
		double *ra = REAL(ans);
50879 ripley 910 
		for(i = 0; i <= nn; i++)
59178 ripley 911 
		    ra[i] = rfrom + (double)i * rby;
50879 ripley 912 
		/* Added in 2.9.0 */
913 
		if (nn > 0)
914 
		    if((rby > 0 && ra[nn] > rto) || (rby < 0 && ra[nn] < rto))
915 
			ra[nn] = rto;
916 
	    }
38997 ripley 917 
	}
918 
    } else if (lout == 0) {
919 
	ans = allocVector(INTSXP, 0);
920 
    } else if (One) {
41715 ripley 921 
	ans = seq_colon(1.0, (double)lout, call);
71917 maechler 922 
    } else if (by == R_MissingArg) { // and  len := length.out  specified
923 
	double rfrom = asReal(from), rto = asReal(to), rby = 0; // -Wall
924 
	if(miss_to)   rto   = rfrom + (double)lout - 1;
925 
	if(miss_from) rfrom = rto   - (double)lout + 1;
926 
	if(!R_FINITE(rfrom)) errorcall(call, _("'%s' must be a finite number"), "from");
927 
	if(!R_FINITE(rto))   errorcall(call, _("'%s' must be a finite number"), "to");
928 
	if(lout > 2) rby = (rto - rfrom)/(double)(lout - 1);
73500 ripley 929 
	if(rfrom <= INT_MAX && rfrom >= INT_MIN &&
930 
	   rto   <= INT_MAX && rto   >= INT_MIN &&
931 
	   rfrom == (int)rfrom &&
71917 maechler 932 
	   (lout <= 1 || rto == (int)rto) &&
73500 ripley 933 
	   (lout <= 2 || rby == (int)rby)) {
71917 maechler 934 
	    ans = allocVector(INTSXP, lout);
71926 ripley 935 
	    if(lout > 0) INTEGER(ans)[0] = (int)rfrom;
936 
	    if(lout > 1) INTEGER(ans)[lout - 1] = (int)rto;
71917 maechler 937 
	    if(lout > 2)
938 
		for(i = 1; i < lout-1; i++) {
939 
//		    if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
940 
		    INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
941 
		}
942 
	} else {
38997 ripley 943 
	ans = allocVector(REALSXP, lout);
944 
	if(lout > 0) REAL(ans)[0] = rfrom;
945 
	if(lout > 1) REAL(ans)[lout - 1] = rto;
946 
	if(lout > 2) {
947 
	    rby = (rto - rfrom)/(double)(lout - 1);
60160 ripley 948 
	    for(i = 1; i < lout-1; i++) {
60336 ripley 949 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
60160 ripley 950 
		REAL(ans)[i] = rfrom + (double)i*rby;
951 
	    }
38997 ripley 952 
	}
71917 maechler 953 
	}
954 
    } else if (miss_to) {
38997 ripley 955 
	double rfrom = asReal(from), rby = asReal(by), rto;
71917 maechler 956 
	if(miss_from) rfrom = 1.0;
957 
	if(!R_FINITE(rfrom)) errorcall(call, _("'%s' must be a finite number"), "from");
958 
	if(!R_FINITE(rby))   errorcall(call, _("'%s' must be a finite number"), "by");
59178 ripley 959 
	rto = rfrom + (double)(lout-1)*rby;
75677 maechler 960 
	if(rby == (int)rby && rfrom == (int)rfrom
961 
	   && rfrom <= INT_MAX && rfrom >= INT_MIN
962 
	   &&  rto  <= INT_MAX &&  rto  >= INT_MIN) {
38997 ripley 963 
	    ans = allocVector(INTSXP, lout);
60160 ripley 964 
	    for(i = 0; i < lout; i++) {
60336 ripley 965 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59178 ripley 966 
		INTEGER(ans)[i] = (int)(rfrom + (double)i*rby);
60160 ripley 967 
	    }
38997 ripley 968 
	} else {
969 
	    ans = allocVector(REALSXP, lout);
60160 ripley 970 
	    for(i = 0; i < lout; i++) {
60336 ripley 971 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59178 ripley 972 
		REAL(ans)[i] = rfrom + (double)i*rby;
60160 ripley 973 
	    }
38997 ripley 974 
	}
71917 maechler 975 
    } else if (miss_from) {
38997 ripley 976 
	double rto = asReal(to), rby = asReal(by),
59178 ripley 977 
	    rfrom = rto - (double)(lout-1)*rby;
71917 maechler 978 
	if(!R_FINITE(rto)) errorcall(call, _("'%s' must be a finite number"), "to");
979 
	if(!R_FINITE(rby)) errorcall(call, _("'%s' must be a finite number"), "by");
75677 maechler 980 
	if(rby == (int)rby && rto == (int)rto
981 
	   && rfrom <= INT_MAX && rfrom >= INT_MIN
982 
	   &&  rto  <= INT_MAX &&  rto  >= INT_MIN) {
38997 ripley 983 
	    ans = allocVector(INTSXP, lout);
60160 ripley 984 
	    for(i = 0; i < lout; i++) {
60336 ripley 985 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59178 ripley 986 
		INTEGER(ans)[i] = (int)(rto - (double)(lout - 1 - i)*rby);
60160 ripley 987 
	    }
38997 ripley 988 
	} else {
989 
	    ans = allocVector(REALSXP, lout);
60160 ripley 990 
	    for(i = 0; i < lout; i++) {
60336 ripley 991 
//		if ((i+1) % NINTERRUPT == 0) R_CheckUserInterrupt();
59178 ripley 992 
		REAL(ans)[i] = rto - (double)(lout - 1 - i)*rby;
60160 ripley 993 
	    }
38997 ripley 994 
	}
995 
    } else
996 
	errorcall(call, _("too many arguments"));
45446 ripley 997 
 
38997 ripley 998 
done:
66326 luke 999 
    UNPROTECT(1);
38997 ripley 1000 
    return ans;
1001 
}
39006 ripley 1002 
 
1003 
SEXP attribute_hidden do_seq_along(SEXP call, SEXP op, SEXP args, SEXP rho)
1004 
{
1005 
    SEXP ans;
59091 ripley 1006 
    R_xlen_t len;
54197 luke 1007 
    static SEXP length_op = NULL;
39006 ripley 1008 
 
54197 luke 1009 
    /* Store the .Primitive for 'length' for DispatchOrEval to use. */
1010 
    if (length_op == NULL) {
1011 
	SEXP R_lengthSymbol = install("length");
1012 
	length_op = eval(R_lengthSymbol, R_BaseEnv);
1013 
	if (TYPEOF(length_op) != BUILTINSXP) {
1014 
	    length_op = NULL;
1015 
	    error("'length' is not a BUILTIN");
1016 
	}
1017 
	R_PreserveObject(length_op);
1018 
    }
1019 
 
39006 ripley 1020 
    checkArity(op, args);
51267 ripley 1021 
    check1arg(args, call, "along.with");
54197 luke 1022 
 
59034 ripley 1023 
    /* Try to dispatch to S3 or S4 methods for 'length'.  For cases
54197 luke 1024 
       where no methods are defined this is more efficient than an
1025 
       unconditional callback to R */
1026 
    if (isObject(CAR(args)) &&
1027 
	DispatchOrEval(call, length_op, "length", args, rho, &ans, 0, 1)) {
48952 maechler 1028 
	len = asInteger(ans);
1029 
    }
1030 
    else
59091 ripley 1031 
	len = xlength(CAR(args));
48952 maechler 1032 
 
74244 luke 1033 
    if (len == 0)
1034 
	return allocVector(INTSXP, 0);
1035 
    else
1036 
	return R_compact_intrange(1, len);
39006 ripley 1037 
}
1038 
 
1039 
SEXP attribute_hidden do_seq_len(SEXP call, SEXP op, SEXP args, SEXP rho)
1040 
{
59966 ripley 1041 
    R_xlen_t len;
39006 ripley 1042 
 
1043 
    checkArity(op, args);
51267 ripley 1044 
    check1arg(args, call, "length.out");
54198 ripley 1045 
    if(length(CAR(args)) != 1)
1046 
	warningcall(call, _("first element used of '%s' argument"),
1047 
		    "length.out");
45446 ripley 1048 
 
59091 ripley 1049 
 #ifdef LONG_VECTOR_SUPPORT
59966 ripley 1050 
    double dlen = asReal(CAR(args));
1051 
    if(!R_FINITE(dlen) || dlen < 0)
1052 
	errorcall(call, _("argument must be coercible to non-negative integer"));
74888 luke 1053 
    if(dlen >= R_XLEN_T_MAX)
1054 
    	errorcall(call, _("result would be too long a vector"));
59966 ripley 1055 
    len = (R_xlen_t) dlen;
1056 
#else
1057 
    len = asInteger(CAR(args));
1058 
    if(len == NA_INTEGER || len < 0)
1059 
	errorcall(call, _("argument must be coercible to non-negative integer"));
1060 
#endif
1061 
 
74244 luke 1062 
    if (len == 0)
1063 
	return allocVector(INTSXP, 0);
1064 
    else
1065 
	return R_compact_intrange(1, len);
39006 ripley 1066 
}