@@ -15,8 +15,11 @@
Loading
15 15
extern SEXP pluck_impl(SEXP, SEXP, SEXP, SEXP);
16 16
extern SEXP flatten_impl(SEXP);
17 17
extern SEXP map_impl(SEXP, SEXP, SEXP, SEXP);
18 +
extern SEXP map_matrix_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
18 19
extern SEXP map2_impl(SEXP, SEXP, SEXP, SEXP, SEXP);
20 +
extern SEXP map2_matrix_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
19 21
extern SEXP pmap_impl(SEXP, SEXP, SEXP, SEXP);
22 +
extern SEXP pmap_matrix_impl(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP);
20 23
extern SEXP transpose_impl(SEXP, SEXP);
21 24
extern SEXP vflatten_impl(SEXP, SEXP);
22 25
@@ -26,8 +29,11 @@
Loading
26 29
  {"pluck_impl",            (DL_FUNC) &pluck_impl,   4},
27 30
  {"flatten_impl",          (DL_FUNC) &flatten_impl,   1},
28 31
  {"map_impl",              (DL_FUNC) &map_impl,       4},
32 +
  {"map_matrix_impl",       (DL_FUNC) &map_matrix_impl, 6},
29 33
  {"map2_impl",             (DL_FUNC) &map2_impl,      5},
34 +
  {"map2_matrix_impl",      (DL_FUNC) &map2_matrix_impl, 7},
30 35
  {"pmap_impl",             (DL_FUNC) &pmap_impl,      4},
36 +
  {"pmap_matrix_impl",      (DL_FUNC) &pmap_matrix_impl, 6},
31 37
  {"transpose_impl",        (DL_FUNC) &transpose_impl, 2},
32 38
  {"vflatten_impl",         (DL_FUNC) &vflatten_impl,  2},
33 39
  {"purrr_eval",            (DL_FUNC) &Rf_eval,        2},

@@ -218,6 +218,41 @@
Loading
218 218
  .Call(map_impl, environment(), ".x", ".f", "raw")
219 219
}
220 220
221 +
#' @rdname map
222 +
#' @export
223 +
map_lgl_matrix <- function(.x, .f, .n, ..., .by_row = FALSE) {
224 +
  .f <- as_mapper(.f, ...)
225 +
  .Call(map_matrix_impl, environment(), ".x", ".f", "logical", .n, .by_row)
226 +
}
227 +
228 +
#' @rdname map
229 +
#' @export
230 +
map_chr_matrix <- function(.x, .f, .n, ..., .by_row = FALSE) {
231 +
  .f <- as_mapper(.f, ...)
232 +
  .Call(map_matrix_impl, environment(), ".x", ".f", "character", .n, .by_row)
233 +
}
234 +
235 +
#' @rdname map
236 +
#' @export
237 +
map_int_matrix <- function(.x, .f, .n, ..., .by_row = FALSE) {
238 +
  .f <- as_mapper(.f, ...)
239 +
  .Call(map_matrix_impl, environment(), ".x", ".f", "integer", .n, .by_row)
240 +
}
241 +
242 +
#' @rdname map
243 +
#' @export
244 +
map_dbl_matrix <- function(.x, .f, .n, ..., .by_row = FALSE) {
245 +
  .f <- as_mapper(.f, ...)
246 +
  .Call(map_matrix_impl, environment(), ".x", ".f", "double", .n, .by_row)
247 +
}
248 +
249 +
#' @rdname map
250 +
#' @export
251 +
map_raw_matrix <- function(.x, .f, .n, ..., .by_row = FALSE) {
252 +
  .f <- as_mapper(.f, ...)
253 +
  .Call(map_matrix_impl, environment(), ".x", ".f", "raw", .n, .by_row)
254 +
}
255 +
221 256
#' @rdname map
222 257
#' @param .id Either a string or `NULL`. If a string, the output will contain
223 258
#'   a variable with that name, storing either the name (if `.x` is named) or

@@ -133,6 +133,38 @@
Loading
133 133
  .f <- as_mapper(.f, ...)
134 134
  .Call(map2_impl, environment(), ".x", ".y", ".f", "raw")
135 135
}
136 +
137 +
#' @export
138 +
#' @rdname map2
139 +
map2_lgl_matrix <- function(.x, .y, .f, .n, ..., .by_row = FALSE) {
140 +
  .f <- as_mapper(.f, ...)
141 +
  .Call(map2_matrix_impl, environment(), ".x", ".y", ".f", "logical", .n, .by_row)
142 +
}
143 +
#' @export
144 +
#' @rdname map2
145 +
map2_int_matrix <- function(.x, .y, .f, .n, ..., .by_row = FALSE) {
146 +
  .f <- as_mapper(.f, ...)
147 +
  .Call(map2_matrix_impl, environment(), ".x", ".y", ".f", "integer", .n, .by_row)
148 +
}
149 +
#' @export
150 +
#' @rdname map2
151 +
map2_dbl_matrix <- function(.x, .y, .f, .n, ..., .by_row = FALSE) {
152 +
  .f <- as_mapper(.f, ...)
153 +
  .Call(map2_matrix_impl, environment(), ".x", ".y", ".f", "double", .n, .by_row)
154 +
}
155 +
#' @export
156 +
#' @rdname map2
157 +
map2_chr_matrix <- function(.x, .y, .f, .n, ..., .by_row = FALSE) {
158 +
  .f <- as_mapper(.f, ...)
159 +
  .Call(map2_matrix_impl, environment(), ".x", ".y", ".f", "character", .n, .by_row)
160 +
}
161 +
#' @export
162 +
#' @rdname map2
163 +
map2_raw_matrix <- function(.x, .y, .f, .n, ..., .by_row = FALSE) {
164 +
  .f <- as_mapper(.f, ...)
165 +
  .Call(map2_matrix_impl, environment(), ".x", ".y", ".f", "raw", .n, .by_row)
166 +
}
167 +
136 168
#' @rdname map2
137 169
#' @export
138 170
map2_dfr <- function(.x, .y, .f, ..., .id = NULL) {
@@ -228,6 +260,61 @@
Loading
228 260
  .Call(pmap_impl, environment(), ".l", ".f", "raw")
229 261
}
230 262
263 +
#' @export
264 +
#' @rdname map2
265 +
pmap_lgl_matrix <- function(.l, .f, .n, ..., .by_row = FALSE) {
266 +
  .f <- as_mapper(.f, ...)
267 +
  if (is.data.frame(.l)) {
268 +
    .l <- as.list(.l)
269 +
  }
270 +
271 +
  .Call(pmap_matrix_impl, environment(), ".l", ".f", "logical", .n, .by_row)
272 +
}
273 +
274 +
#' @export
275 +
#' @rdname map2
276 +
pmap_int_matrix <- function(.l, .f, .n, ..., .by_row = FALSE) {
277 +
  .f <- as_mapper(.f, ...)
278 +
  if (is.data.frame(.l)) {
279 +
    .l <- as.list(.l)
280 +
  }
281 +
282 +
  .Call(pmap_matrix_impl, environment(), ".l", ".f", "integer", .n, .by_row)
283 +
}
284 +
285 +
#' @export
286 +
#' @rdname map2
287 +
pmap_dbl_matrix <- function(.l, .f, .n, ..., .by_row = FALSE) {
288 +
  .f <- as_mapper(.f, ...)
289 +
  if (is.data.frame(.l)) {
290 +
    .l <- as.list(.l)
291 +
  }
292 +
293 +
  .Call(pmap_matrix_impl, environment(), ".l", ".f", "double", .n, .by_row)
294 +
}
295 +
296 +
#' @export
297 +
#' @rdname map2
298 +
pmap_chr_matrix <- function(.l, .f, .n, ..., .by_row = FALSE) {
299 +
  .f <- as_mapper(.f, ...)
300 +
  if (is.data.frame(.l)) {
301 +
    .l <- as.list(.l)
302 +
  }
303 +
304 +
  .Call(pmap_matrix_impl, environment(), ".l", ".f", "character", .n, .by_row)
305 +
}
306 +
307 +
#' @export
308 +
#' @rdname map2
309 +
pmap_raw_matrix <- function(.l, .f, .n, ..., .by_row = FALSE) {
310 +
  .f <- as_mapper(.f, ...)
311 +
  if (is.data.frame(.l)) {
312 +
    .l <- as.list(.l)
313 +
  }
314 +
315 +
  .Call(pmap_matrix_impl, environment(), ".l", ".f", "raw", .n, .by_row)
316 +
}
317 +
231 318
#' @rdname map2
232 319
#' @export
233 320
pmap_dfr <- function(.l, .f, ..., .id = NULL) {

@@ -57,6 +57,49 @@
Loading
57 57
  return out;
58 58
}
59 59
60 +
// call must involve i
61 +
SEXP call_loop_matrix(SEXP env, SEXP call, int n, int m, SEXPTYPE type, int force_args, int by_row) {
62 +
  // Create variable "i" and map to scalar integer
63 +
  SEXP i_val = PROTECT(Rf_ScalarInteger(1));
64 +
  SEXP i = Rf_install("i");
65 +
  Rf_defineVar(i, i_val, env);
66 +
67 +
  SEXP out;
68 +
  if (by_row) {
69 +
    out = PROTECT(Rf_allocMatrix(type, n, m));
70 +
  } else {
71 +
    out = PROTECT(Rf_allocMatrix(type, m, n));
72 +
  }
73 +
  for (int i = 0; i < n; ++i) {
74 +
    if (i % 1024 == 0)
75 +
      R_CheckUserInterrupt();
76 +
77 +
    INTEGER(i_val)[0] = i + 1;
78 +
79 +
#if defined(R_VERSION) && R_VERSION >= R_Version(3, 2, 3)
80 +
    SEXP res = PROTECT(R_forceAndCall(call, force_args, env));
81 +
#else
82 +
    SEXP res = PROTECT(Rf_eval(call, env));
83 +
#endif
84 +
    if (type != VECSXP && Rf_length(res) != m) {
85 +
      SEXP ptype = PROTECT(Rf_allocVector(type, 0));
86 +
      stop_bad_element_vector(res, i + 1, ptype, m, "Result", NULL, false);
87 +
    }
88 +
89 +
    for (int j = 0; j < m; j++) {
90 +
      if (by_row) {
91 +
        set_vector_value(out, n * j + i, res, j);
92 +
      } else {
93 +
        set_vector_value(out, m * i + j, res, j);
94 +
      }
95 +
    }
96 +
    UNPROTECT(1);
97 +
  }
98 +
99 +
  UNPROTECT(2);
100 +
  return out;
101 +
}
102 +
60 103
SEXP map_impl(SEXP env, SEXP x_name_, SEXP f_name_, SEXP type_) {
61 104
  const char* x_name = CHAR(Rf_asChar(x_name_));
62 105
  const char* f_name = CHAR(Rf_asChar(f_name_));
@@ -91,6 +134,42 @@
Loading
91 134
  return out;
92 135
}
93 136
137 +
SEXP map_matrix_impl(SEXP env, SEXP x_name_, SEXP f_name_, SEXP type_, SEXP n_elem_, SEXP by_row_) {
138 +
  const char* x_name = CHAR(Rf_asChar(x_name_));
139 +
  const char* f_name = CHAR(Rf_asChar(f_name_));
140 +
  const int n_elem = Rf_asInteger(n_elem_);
141 +
  const int by_row = Rf_asLogical(by_row_);
142 +
143 +
  SEXP x = Rf_install(x_name);
144 +
  SEXP f = Rf_install(f_name);
145 +
  SEXP i = Rf_install("i");
146 +
  SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_)));
147 +
148 +
  SEXP x_val = PROTECT(Rf_eval(x, env));
149 +
  check_vector(x_val, ".x");
150 +
151 +
  int n = Rf_length(x_val);
152 +
  if (n == 0) {
153 +
    SEXP out = PROTECT(Rf_allocVector(type, 0));
154 +
    copy_names(x_val, out);
155 +
    UNPROTECT(2);
156 +
    return out;
157 +
  }
158 +
159 +
  // Constructs a call like f(x[[i]], ...) - don't want to substitute
160 +
  // actual values for f or x, because they may be long, which creates
161 +
  // bad tracebacks()
162 +
  SEXP Xi = PROTECT(Rf_lang3(R_Bracket2Symbol, x, i));
163 +
  SEXP f_call = PROTECT(Rf_lang3(f, Xi, R_DotsSymbol));
164 +
165 +
  SEXP out = PROTECT(call_loop_matrix(env, f_call, n, n_elem, type, 1, by_row));
166 +
  copy_names(x_val, out);
167 +
168 +
  UNPROTECT(4);
169 +
170 +
  return out;
171 +
}
172 +
94 173
SEXP map2_impl(SEXP env, SEXP x_name_, SEXP y_name_, SEXP f_name_, SEXP type_) {
95 174
  const char* x_name = CHAR(Rf_asChar(x_name_));
96 175
  const char* y_name = CHAR(Rf_asChar(y_name_));
@@ -137,6 +216,54 @@
Loading
137 216
  return out;
138 217
}
139 218
219 +
SEXP map2_matrix_impl(SEXP env, SEXP x_name_, SEXP y_name_, SEXP f_name_, SEXP type_, SEXP n_elem_, SEXP by_row_) {
220 +
  const char* x_name = CHAR(Rf_asChar(x_name_));
221 +
  const char* y_name = CHAR(Rf_asChar(y_name_));
222 +
  const char* f_name = CHAR(Rf_asChar(f_name_));
223 +
  const int n_elem = Rf_asInteger(n_elem_);
224 +
  const int by_row = Rf_asLogical(by_row_);
225 +
226 +
  SEXP x = Rf_install(x_name);
227 +
  SEXP y = Rf_install(y_name);
228 +
  SEXP f = Rf_install(f_name);
229 +
  SEXP i = Rf_install("i");
230 +
  SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_)));
231 +
232 +
  SEXP x_val = PROTECT(Rf_eval(x, env));
233 +
  check_vector(x_val, ".x");
234 +
  SEXP y_val = PROTECT(Rf_eval(y, env));
235 +
  check_vector(y_val, ".y");
236 +
237 +
  int nx = Rf_length(x_val), ny = Rf_length(y_val);
238 +
  if (nx == 0 || ny == 0) {
239 +
    SEXP out = PROTECT(Rf_allocVector(type, 0));
240 +
    copy_names(x_val, out);
241 +
    UNPROTECT(3);
242 +
    return out;
243 +
  }
244 +
  if (nx != ny && !(nx == 1 || ny == 1)) {
245 +
    Rf_errorcall(R_NilValue,
246 +
                 "Mapped vectors must have consistent lengths:\n"
247 +
                 "* `.x` has length %d\n"
248 +
                 "* `.y` has length %d",
249 +
                 nx,
250 +
                 ny);
251 +
  }
252 +
  int n = (nx > ny) ? nx : ny;
253 +
254 +
  // Constructs a call like f(x[[i]], y[[i]], ...)
255 +
  SEXP one = PROTECT(Rf_ScalarInteger(1));
256 +
  SEXP Xi = PROTECT(Rf_lang3(R_Bracket2Symbol, x, nx == 1 ? one : i));
257 +
  SEXP Yi = PROTECT(Rf_lang3(R_Bracket2Symbol, y, ny == 1 ? one : i));
258 +
  SEXP f_call = PROTECT(Rf_lang4(f, Xi, Yi, R_DotsSymbol));
259 +
260 +
  SEXP out = PROTECT(call_loop_matrix(env, f_call, n, n_elem, type, 2, by_row));
261 +
  copy_names(x_val, out);
262 +
263 +
  UNPROTECT(7);
264 +
  return out;
265 +
}
266 +
140 267
SEXP pmap_impl(SEXP env, SEXP l_name_, SEXP f_name_, SEXP type_) {
141 268
  const char* l_name = CHAR(Rf_asChar(l_name_));
142 269
  SEXP l = Rf_install(l_name);
@@ -229,3 +356,98 @@
Loading
229 356
  UNPROTECT(5);
230 357
  return out;
231 358
}
359 +
360 +
SEXP pmap_matrix_impl(SEXP env, SEXP l_name_, SEXP f_name_, SEXP type_, SEXP n_elem_, SEXP by_row_) {
361 +
  const char* l_name = CHAR(Rf_asChar(l_name_));
362 +
  SEXP l = Rf_install(l_name);
363 +
  SEXP l_val = PROTECT(Rf_eval(l, env));
364 +
  SEXPTYPE type = Rf_str2type(CHAR(Rf_asChar(type_)));
365 +
  const int n_elem = Rf_asInteger(n_elem_);
366 +
  const int by_row = Rf_asLogical(by_row_);
367 +
368 +
  if (!Rf_isVectorList(l_val)) {
369 +
    stop_bad_type(l_val, "a list", NULL, l_name);
370 +
  }
371 +
372 +
  // Check all elements are lists and find maximum length
373 +
  int m = Rf_length(l_val);
374 +
  int n = 0;
375 +
  for (int j = 0; j < m; ++j) {
376 +
    SEXP j_val = VECTOR_ELT(l_val, j);
377 +
378 +
    if (!Rf_isVector(j_val) && !Rf_isNull(j_val)) {
379 +
      stop_bad_element_type(j_val, j + 1, "a vector", NULL, l_name);
380 +
    }
381 +
382 +
    int nj = Rf_length(j_val);
383 +
384 +
    if (nj == 0) {
385 +
      SEXP out = PROTECT(Rf_allocVector(type, 0));
386 +
      copy_names(j_val, out);
387 +
      UNPROTECT(2);
388 +
      return out;
389 +
    }
390 +
391 +
    if (nj > n) {
392 +
      n = nj;
393 +
    }
394 +
395 +
  }
396 +
397 +
  // Check length of all elements
398 +
  for (int j = 0; j < m; ++j) {
399 +
    SEXP j_val = VECTOR_ELT(l_val, j);
400 +
    int nj = Rf_length(j_val);
401 +
402 +
    if (nj != 1 && nj != n) {
403 +
      stop_bad_element_length(j_val, j + 1, n, NULL, ".l", true);
404 +
    }
405 +
  }
406 +
407 +
  SEXP l_names = PROTECT(Rf_getAttrib(l_val, R_NamesSymbol));
408 +
  int has_names = !Rf_isNull(l_names);
409 +
410 +
  const char* f_name = CHAR(Rf_asChar(f_name_));
411 +
  SEXP f = Rf_install(f_name);
412 +
  SEXP i = Rf_install("i");
413 +
  SEXP one = PROTECT(Rf_ScalarInteger(1));
414 +
415 +
  // Construct call like f(.l[[1]][[i]], .l[[2]][[i]], ...)
416 +
  //
417 +
  // Currently accessing S3 vectors in a list like .l[[c(1, i)]] will not
418 +
  // preserve the class (cf. #358).
419 +
  //
420 +
  // We construct the call backwards because can only add to the front of a
421 +
  // linked list. That makes PROTECTion tricky because we need to update it
422 +
  // each time to point to the start of the linked list.
423 +
424 +
  SEXP f_call = Rf_lang1(R_DotsSymbol);
425 +
  PROTECT_INDEX fi;
426 +
  PROTECT_WITH_INDEX(f_call, &fi);
427 +
428 +
  for (int j = m - 1; j >= 0; --j) {
429 +
    int nj = Rf_length(VECTOR_ELT(l_val, j));
430 +
431 +
    // Construct call like .l[[j]][[i]]
432 +
    SEXP j_ = PROTECT(Rf_ScalarInteger(j + 1));
433 +
    SEXP l_j = PROTECT(Rf_lang3(R_Bracket2Symbol, l, j_));
434 +
    SEXP l_ji = PROTECT(Rf_lang3(R_Bracket2Symbol, l_j, nj == 1 ? one : i));
435 +
436 +
    REPROTECT(f_call = Rf_lcons(l_ji, f_call), fi);
437 +
    if (has_names && CHAR(STRING_ELT(l_names, j))[0] != '\0')
438 +
      SET_TAG(f_call, Rf_install(CHAR(STRING_ELT(l_names, j))));
439 +
440 +
    UNPROTECT(3);
441 +
  }
442 +
443 +
  REPROTECT(f_call = Rf_lcons(f, f_call), fi);
444 +
445 +
  SEXP out = PROTECT(call_loop_matrix(env, f_call, n, n_elem, type, m, by_row));
446 +
447 +
  if (Rf_length(l_val)) {
448 +
    copy_names(VECTOR_ELT(l_val, 0), out);
449 +
  }
450 +
451 +
  UNPROTECT(5);
452 +
  return out;
453 +
}

@@ -103,7 +103,6 @@
Loading
103 103
  }
104 104
}
105 105
106 -
107 106
SEXP coerce_impl(SEXP x, SEXP type_) {
108 107
  int n = Rf_length(x);
109 108
Files Coverage
R 88.88%
src 76.38%
Project Totals (46 files) 84.01%
1
comment: false
2

3
coverage:
4
  status:
5
    project:
6
      default:
7
        target: auto
8
        threshold: 1%
9
        informational: true
10
    patch:
11
      default:
12
        target: auto
13
        threshold: 1%
14
        informational: true
Sunburst
The inner-most circle is the entire project, moving away from the center are folders then, finally, a single file. The size and color of each slice is representing the number of statements and the coverage, respectively.
Icicle
The top section represents the entire project. Proceeding with folders and finally individual files. The size and color of each slice is representing the number of statements and the coverage, respectively.
Grid
Each block represents a single file in the project. The size and color of each block is represented by the number of statements and the coverage, respectively.
Loading