1 /*
2 * R : A Computer Language for Statistical Data Analysis
3 * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka
4 * Copyright (C) 1997-2013 The R Core Team
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
17 * along with this program; if not, a copy is available at
18 * https://www.R-project.org/Licenses/
19 */
20
21 #ifdef HAVE_CONFIG_H
22 #include <config.h>
23 #endif
24
25 #include <Defn.h>
26 #define R_MSG_type _("invalid 'type' (%s) of argument")
27
28 #undef _
29 #ifdef ENABLE_NLS
30 #include <libintl.h>
31 #define _(String) dgettext ("stats", String)
32 #else
33 #define _(String) (String)
34 #endif
35
36 /* Formerly in src/main/summary.c */
37
38 /* complete.cases(.) */
compcases(SEXP args)39 SEXP compcases(SEXP args)
40 {
41 SEXP s, t, u, rval;
42 int i, len;
43
44 args = CDR(args);
45
46 len = -1;
47
48 for (s = args; s != R_NilValue; s = CDR(s)) {
49 if (isList(CAR(s))) {
50 for (t = CAR(s); t != R_NilValue; t = CDR(t))
51 if (isMatrix(CAR(t))) {
52 u = getAttrib(CAR(t), R_DimSymbol);
53 if (len < 0)
54 len = INTEGER(u)[0];
55 else if (len != INTEGER(u)[0])
56 goto bad;
57 }
58 else if (isVector(CAR(t))) {
59 if (len < 0)
60 len = LENGTH(CAR(t));
61 else if (len != LENGTH(CAR(t)))
62 goto bad;
63 }
64 else
65 error(R_MSG_type, type2char(TYPEOF(CAR(t))));
66 }
67 /* FIXME : Need to be careful with the use of isVector() */
68 /* since this includes lists and expressions. */
69 else if (isNewList(CAR(s))) {
70 int it, nt;
71 t = CAR(s);
72 nt = length(t);
73 /* 0-column data frames are a special case */
74 if(nt) {
75 for (it = 0 ; it < nt ; it++) {
76 if (isMatrix(VECTOR_ELT(t, it))) {
77 u = getAttrib(VECTOR_ELT(t, it), R_DimSymbol);
78 if (len < 0)
79 len = INTEGER(u)[0];
80 else if (len != INTEGER(u)[0])
81 goto bad;
82 }
83 else if (isVector(VECTOR_ELT(t, it))) {
84 if (len < 0)
85 len = LENGTH(VECTOR_ELT(t, it));
86 else if (len != LENGTH(VECTOR_ELT(t, it)))
87 goto bad;
88 }
89 else
90 error(R_MSG_type, "unknown");
91 }
92 } else {
93 u = getAttrib(t, R_RowNamesSymbol);
94 if (!isNull(u)) {
95 if (len < 0)
96 len = LENGTH(u);
97 else if (len != INTEGER(u)[0])
98 goto bad;
99 }
100 }
101 }
102 else if (isMatrix(CAR(s))) {
103 u = getAttrib(CAR(s), R_DimSymbol);
104 if (len < 0)
105 len = INTEGER(u)[0];
106 else if (len != INTEGER(u)[0])
107 goto bad;
108 }
109 else if (isVector(CAR(s))) {
110 if (len < 0)
111 len = LENGTH(CAR(s));
112 else if (len != LENGTH(CAR(s)))
113 goto bad;
114 }
115 else
116 error(R_MSG_type, type2char(TYPEOF(CAR(s))));
117 }
118
119 if (len < 0)
120 error(_("no input has determined the number of cases"));
121 PROTECT(rval = allocVector(LGLSXP, len));
122 for (i = 0; i < len; i++) INTEGER(rval)[i] = 1;
123 /* FIXME : there is a lot of shared code here for vectors. */
124 /* It should be abstracted out and optimized. */
125 for (s = args; s != R_NilValue; s = CDR(s)) {
126 if (isList(CAR(s))) {
127 /* Now we only need to worry about vectors */
128 /* since we use mod to handle arrays. */
129 /* FIXME : using mod like this causes */
130 /* a potential performance hit. */
131 for (t = CAR(s); t != R_NilValue; t = CDR(t)) {
132 u = CAR(t);
133 for (i = 0; i < LENGTH(u); i++) {
134 switch (TYPEOF(u)) {
135 case INTSXP:
136 case LGLSXP:
137 if (INTEGER(u)[i] == NA_INTEGER)
138 INTEGER(rval)[i % len] = 0;
139 break;
140 case REALSXP:
141 if (ISNAN(REAL(u)[i]))
142 INTEGER(rval)[i % len] = 0;
143 break;
144 case CPLXSXP:
145 if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
146 INTEGER(rval)[i % len] = 0;
147 break;
148 case STRSXP:
149 if (STRING_ELT(u, i) == NA_STRING)
150 INTEGER(rval)[i % len] = 0;
151 break;
152 default:
153 UNPROTECT(1);
154 error(R_MSG_type, type2char(TYPEOF(u)));
155 }
156 }
157 }
158 }
159 if (isNewList(CAR(s))) {
160 int it, nt;
161 t = CAR(s);
162 nt = length(t);
163 for (it = 0 ; it < nt ; it++) {
164 u = VECTOR_ELT(t, it);
165 for (i = 0; i < LENGTH(u); i++) {
166 switch (TYPEOF(u)) {
167 case INTSXP:
168 case LGLSXP:
169 if (INTEGER(u)[i] == NA_INTEGER)
170 INTEGER(rval)[i % len] = 0;
171 break;
172 case REALSXP:
173 if (ISNAN(REAL(u)[i]))
174 INTEGER(rval)[i % len] = 0;
175 break;
176 case CPLXSXP:
177 if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
178 INTEGER(rval)[i % len] = 0;
179 break;
180 case STRSXP:
181 if (STRING_ELT(u, i) == NA_STRING)
182 INTEGER(rval)[i % len] = 0;
183 break;
184 default:
185 UNPROTECT(1);
186 error(R_MSG_type, type2char(TYPEOF(u)));
187 }
188 }
189 }
190 }
191 else {
192 for (i = 0; i < LENGTH(CAR(s)); i++) {
193 u = CAR(s);
194 switch (TYPEOF(u)) {
195 case INTSXP:
196 case LGLSXP:
197 if (INTEGER(u)[i] == NA_INTEGER)
198 INTEGER(rval)[i % len] = 0;
199 break;
200 case REALSXP:
201 if (ISNAN(REAL(u)[i]))
202 INTEGER(rval)[i % len] = 0;
203 break;
204 case CPLXSXP:
205 if (ISNAN(COMPLEX(u)[i].r) || ISNAN(COMPLEX(u)[i].i))
206 INTEGER(rval)[i % len] = 0;
207 break;
208 case STRSXP:
209 if (STRING_ELT(u, i) == NA_STRING)
210 INTEGER(rval)[i % len] = 0;
211 break;
212 default:
213 UNPROTECT(1);
214 error(R_MSG_type, type2char(TYPEOF(u)));
215 }
216 }
217 }
218 }
219 UNPROTECT(1);
220 return rval;
221
222 bad:
223 error(_("not all arguments have the same length"));
224 return R_NilValue; /* -Wall */
225 }
226