gogonzo / runner

@@ -170,9 +170,88 @@
Loading
170 170
#'   f = mean
171 171
#' )
172 172
#' @md
173 +
#' @rdname runner
173 174
#' @importFrom methods is
174 175
#' @export
175 -
runner <- function(
176 +
runner <- function (
177 +
  x,
178 +
  f = function(x) x,
179 +
  k = integer(0),
180 +
  lag = integer(1),
181 +
  idx = integer(0),
182 +
  at = integer(0),
183 +
  na_pad = FALSE,
184 +
  type = "auto",
185 +
  ...
186 +
  ) {
187 +
  UseMethod("runner", x)
188 +
}
189 +
190 +
#' @rdname runner
191 +
#' @export
192 +
runner.data.frame <- function(
193 +
  x,
194 +
  f = function(x) x,
195 +
  k = integer(0),
196 +
  lag = integer(1),
197 +
  idx = integer(0),
198 +
  at = integer(0),
199 +
  na_pad = FALSE,
200 +
  type = "auto",
201 +
  ...
202 +
  ) {
203 +
204 +
  # dplyr::group_by exception
205 +
  x <- this_group(x)
206 +
207 +
  # set arguments from attrs set by run_by
208 +
  k <- set_from_attribute_difftime(x, k) # no deep copy
209 +
  lag <- set_from_attribute_difftime(x, lag)
210 +
  idx <- set_from_attribute_index(x, idx)
211 +
  at <- set_from_attribute_at(x, at)
212 +
  na_pad <- set_from_attribute_logical(x, na_pad)
213 +
214 +
  if (any(is.na(k))) {
215 +
    stop("Function doesn't accept NA values in k vector");
216 +
  }
217 +
  if (any(is.na(lag))) {
218 +
    stop("Function doesn't accept NA values in lag vector");
219 +
  }
220 +
  if (any(is.na(idx))) {
221 +
    stop("Function doesn't accept NA values in idx vector");
222 +
  }
223 +
  if (!is(f, "function")) {
224 +
    stop("f should be a function")
225 +
  }
226 +
227 +
  # use POSIXt.seq
228 +
  at  <- seq_at(at, idx)
229 +
  k   <- k_by(k,   if (length(at) > 0) at else idx, "k")
230 +
  lag <- k_by(lag, if (length(at) > 0) at else idx, "lag")
231 +
232 +
  w <- window_run(
233 +
    x = seq_len(nrow(x)),
234 +
    k = k,
235 +
    lag = lag,
236 +
    idx = idx,
237 +
    at = at,
238 +
    na_pad = na_pad
239 +
  )
240 +
241 +
  res <- sapply(w, function(ww) {
242 +
    if (length(ww) == 0) {
243 +
      NA
244 +
    } else {
245 +
      f(x[ww, ], ...)
246 +
    }
247 +
  })
248 +
249 +
  return(res)
250 +
}
251 +
252 +
#' @rdname runner
253 +
#' @export
254 +
runner.default <- function(
176 255
  x,
177 256
  f = function(x) x,
178 257
  k = integer(0),
@@ -198,16 +277,13 @@
Loading
198 277
  }
199 278
200 279
201 -
  at <- seq_by(at, idx)
280 +
  # use POSIXt.seq
281 +
  at <- seq_at(at, idx)
202 282
  k <- k_by(k, if (length(at > 0)) at else idx, "k")
203 283
  lag <- k_by(lag, if (length(at > 0)) at else idx, "lag")
204 284
205 285
  w <- window_run(
206 -
    x = if (is.data.frame(x) || is.matrix(x)) {
207 -
      seq_len(nrow(x))
208 -
    } else {
209 -
      x
210 -
    },
286 +
    x = x,
211 287
    k = k,
212 288
    lag = lag,
213 289
    idx = idx,
@@ -215,16 +291,7 @@
Loading
215 291
    na_pad = na_pad
216 292
  )
217 293
218 -
  if (is.data.frame(x) || is.matrix(x)) {
219 -
    res <- sapply(w, function(ww) {
220 -
      if (length(ww) == 0) {
221 -
        NA
222 -
      } else {
223 -
        f(x[ww, ], ...)
224 -
      }
225 -
    })
226 -
227 -
  } else if (type != "auto") {
294 +
  if (type != "auto") {
228 295
    n <- length(w)
229 296
    res <- vector(mode = type, length = n)
230 297
    for (i in seq_len(n)) {
@@ -235,6 +302,7 @@
Loading
235 302
        f(ww, ...)
236 303
      }
237 304
    }
305 +
238 306
  } else {
239 307
    res <- sapply(w, function(ww)
240 308
      if (is.null(ww)) {
@@ -245,43 +313,29 @@
Loading
245 313
    )
246 314
  }
247 315
248 -
249 316
  return(res)
250 317
}
251 318
252 -
#' Creates sequence for at as time-unit-interval
253 -
#'
254 -
#' Creates sequence for at as time-unit-interval
255 -
#' @param at object from runner
256 -
#' @param idx object from runner
257 -
seq_by <- function(at, idx) {
258 -
  if ((is.character(at) &&
259 -
       length(at) == 1)) {
319 +
get_parent_call_arg_names <- function() {
320 +
  cl <- sys.call(-2)
321 +
  f <- get(as.character(cl[[1]]), mode="function", sys.frame(-2))
322 +
  cl <- match.call(definition=f, call=cl)
323 +
  names(cl)
324 +
}
260 325
261 -
    if (length(idx) == 0) {
262 -
      stop(
263 -
        sprintf("`idx` can't be empty while specifying at as time interval")
264 -
      )
265 -
    }
326 +
is_datetime_valid <- function(x) {
327 +
  all(
328 +
    grepl("^(sec|min|hour|day|DSTday|week|month|quarter|year)$", x = x) |
329 +
      grepl("^-*[0-9]+ (sec|min|hour|day|DSTday|week|month|quarter|year)s", x = x)
330 +
  )
266 331
267 -
    if (inherits(idx, c("Date", "POSIXct", "POSIXxt", "POSIXlt"))) {
268 -
      at <- if (grepl("^-", at)) {
269 -
        seq(max(idx), min(idx), by = at)
270 -
      } else {
271 -
        seq(min(idx), max(idx), by = at)
272 -
      }
273 -
    } else {
274 -
      stop("To specify at as time interval character `idx` can't be empty")
275 -
    }
276 -
  }
277 -
  return(at)
278 332
}
279 333
334 +
280 335
#' Converts k and lag from time-unit-interval to int
281 336
#'
282 337
#' Converts k and lag from time-unit-interval to int
283 -
#' @param k object from runner
284 -
#' @param idx object from runner
338 +
#' @inheritParams runner
285 339
#' @param param name of the parameter to be printed in error message
286 340
#' @examples
287 341
#' k <-  "1 month"
@@ -296,7 +350,13 @@
Loading
296 350
      reformat_k(k, only_positive = FALSE)
297 351
    }
298 352
299 -
    from <- if (length(idx) == length(k) && length(k) != 1) {
353 +
    from <- if (length(k) != 1) {
354 +
      if (length(idx) == 0) {
355 +
        stop(
356 +
          sprintf("`idx` can't be empty while specifying `%s` as time interval", param)
357 +
        )
358 +
      }
359 +
300 360
      mapply(
301 361
        FUN = function(x, y) {
302 362
          seq(x, by = y, length.out = 2)[2]
@@ -307,7 +367,7 @@
Loading
307 367
    } else if (length(k) == 1) {
308 368
      if (length(idx) == 0) {
309 369
        stop(
310 -
          sprintf("`idx` can't be empty while specifying %s='%s'", param, k)
370 +
          sprintf("`idx` can't be empty while specifying `%s` as time interval", param)
311 371
        )
312 372
      }
313 373
@@ -318,17 +378,37 @@
Loading
318 378
      )
319 379
    }
320 380
321 -
    return(as.numeric(idx) - from)
381 +
    return(as.integer(idx) - from)
382 +
383 +
  } else if (is(k, "difftime")) {
384 +
    k <- if (param == "k") {
385 +
      if (any(k < 0)) {
386 +
        stop("`k` can't be negative.")
387 +
      }
388 +
      abs(k)
389 +
    } else {
390 +
      k
391 +
    }
392 +
393 +
    if (length(idx) == 0) {
394 +
      stop(
395 +
        sprintf("`idx` can't be empty while specifying %s as difftime", param)
396 +
      )
397 +
    }
398 +
    from <- idx - k
399 +
    k <- as.integer(idx) - as.integer(from)
322 400
  }
323 401
324 402
  return(k)
325 403
}
326 404
405 +
406 +
327 407
#' Formats time-unit-interval to valid for runner
328 408
#'
329 409
#' Formats time-unit-interval to valid for runner
330 410
#' @param k (k or lag) object from runner to be formatted
331 -
#' @param only_positive for k is TRUE, for lag is FALSE
411 +
#' @param only_positive for \code{k} is \code{TRUE}, for \code{lag} is \code{FALSE}
332 412
#' @examples
333 413
#' runner:::reformat_k("1 days")
334 414
#' runner:::reformat_k("day")
@@ -349,3 +429,376 @@
Loading
349 429
350 430
  return(k)
351 431
}
432 +
433 +
#' Set window parameters
434 +
#'
435 +
#' Set window parameters for \link{runner}. This function sets the
436 +
#' attributes to \code{x} (only \code{data.frame}) object and saves user effort
437 +
#' to specify window parameters in further multiple \link{runner} calls.
438 +
#' @inheritParams runner
439 +
#' @return x object which \link{runner} can be executed on.
440 +
#' @examples
441 +
#' library(dplyr)
442 +
#'
443 +
#' data <- data.frame(
444 +
#'  index = c(2, 3, 3, 4, 5, 8, 10, 10, 13, 15),
445 +
#'  a = rep(c("a", "b"), each = 5),
446 +
#'  b = 1:10
447 +
#' )
448 +
#'
449 +
#' data %>%
450 +
#'  group_by(a) %>%
451 +
#'  run_by(idx = "index", k = 5) %>%
452 +
#'  mutate(
453 +
#'    c = runner(
454 +
#'      x = .,
455 +
#'      f = function(x) {
456 +
#'        paste(x$b, collapse = ">")
457 +
#'      }
458 +
#'    ),
459 +
#'    d = runner(
460 +
#'      x = .,
461 +
#'      f = function(x) {
462 +
#'        sum(x$b)
463 +
#'      }
464 +
#'    )
465 +
#'  )
466 +
#' @export
467 +
run_by <- function(x, idx, k, lag, na_pad, at) {
468 +
  if (!is.data.frame(x)) {
469 +
    stop("`run_by` should be used only for `data.frame`. \n
470 +
         Use `runner` on x directly.")
471 +
  }
472 +
473 +
  if (!missing(k)) x <- set_run_by_difftime(x, k)
474 +
  if (!missing(lag)) x <- set_run_by_difftime(x, lag)
475 +
  if (!missing(idx)) x <- set_run_by_index(x, idx)
476 +
  if (!missing(at)) x <- set_run_by_index(x, at)
477 +
  if (!missing(na_pad)) attr(x, "na_pad") <- na_pad
478 +
479 +
  return(x)
480 +
}
481 +
482 +
483 +
484 +
485 +
#' Creates sequence for at as time-unit-interval
486 +
#'
487 +
#' Creates sequence for at as time-unit-interval
488 +
#' @param at object from runner
489 +
#' @param idx object from runner
490 +
seq_at <- function(at, idx) {
491 +
  if (length(at) == 1 &&
492 +
      (
493 +
        (is.character(at) && is_datetime_valid(at)) ||
494 +
        is(at, "difftime")
495 +
      )
496 +
    ) {
497 +
498 +
    if (length(idx) == 0) {
499 +
      stop(
500 +
        sprintf("`idx` can't be empty while specifying `at` as time interval")
501 +
      )
502 +
    }
503 +
504 +
505 +
    if (inherits(idx, c("Date", "POSIXct", "POSIXxt", "POSIXlt"))) {
506 +
      at <- if ((is.character(at) && grepl("^-", at)) ||
507 +
                (is(at, "difftime") && at < 0)) {
508 +
        seq(max(idx), min(idx), by = at)
509 +
      } else {
510 +
        seq(min(idx), max(idx), by = at)
511 +
      }
512 +
    }
513 +
  }
514 +
  return(at)
515 +
}
516 +
517 +
set_run_by_index <- function(x, arg) {
518 +
  arg_name <- deparse(substitute(arg))
519 +
520 +
  attr(x, arg_name) <- if (is.character(arg) && length(arg) == 1 && arg %in% names(x)) {
521 +
    arg
522 +
523 +
  } else if (is.numeric(arg) || inherits(arg, c("Date", "POSIXct", "POSIXxt", "POSIXlt"))) {
524 +
    arg
525 +
  } else {
526 +
    stop(
527 +
      sprintf(
528 +
        "`%s` should be either:
529 +
         - column name of `x`
530 +
         - vector of type `numeric`, `Date`, `POSIXct` or `POSIXlt`",
531 +
        arg_name
532 +
      ),
533 +
      call. = FALSE
534 +
    )
535 +
  }
536 +
  return(x)
537 +
}
538 +
539 +
set_run_by_difftime <- function(x, arg) {
540 +
  arg_name <- deparse(substitute(arg))
541 +
542 +
  attr(x, arg_name) <- if (is.character(arg)) {
543 +
    if (length(arg) == 1 && arg %in% names(x)) {
544 +
      arg
545 +
    } else if (all(is_datetime_valid(arg))) {
546 +
      arg
547 +
    } else {
548 +
      stop(
549 +
        sprintf(
550 +
          "`%s` is invalid, should be either:
551 +
           - column name of `x`
552 +
           - `difftime` class or character describing diffitme (see at argument in `seq.POSIXt`)
553 +
           - `numeric` or `integer` vector",
554 +
          arg_name
555 +
        ),
556 +
        call. = FALSE
557 +
      )
558 +
    }
559 +
  } else if (is.numeric(arg) || is(arg, "difftime")) {
560 +
    arg
561 +
  } else {
562 +
    stop(
563 +
      sprintf(
564 +
        "`%s` is invalid, should be either:
565 +
           - column name of `x`
566 +
           - `difftime` class or character describing diffitme (see at argument in `seq.POSIXt`)
567 +
           - `numeric` or `integer` `vector`",
568 +
        arg_name
569 +
      ),
570 +
      call. = FALSE
571 +
    )
572 +
  }
573 +
  return(x)
574 +
}
575 +
576 +
set_from_attribute_index <- function(x, attrib) {
577 +
  runner_args <- get_parent_call_arg_names()
578 +
  arg_name <- deparse(substitute(attrib))
579 +
580 +
  # no arg overwriting
581 +
  if (!is.null(attr(x, arg_name)) && !arg_name %in% runner_args) {
582 +
    if (length(attr(x, arg_name)) == 1 &&
583 +
        is.character(attr(x, arg_name)) &&
584 +
        attr(x, arg_name) %in% names(x)) {
585 +
586 +
      attrib <- x[[attr(x, arg_name)]]
587 +
    } else if (is.character(attr(x, arg_name))) {
588 +
      stop(
589 +
        sprintf(
590 +
          "`%s` should be either:
591 +
         - column name of `x`
592 +
         - vector of type `numeric`, `Date`, `POSIXct` or `POSIXlt`",
593 +
          arg_name
594 +
        ),
595 +
        call. = FALSE
596 +
      )
597 +
    } else {
598 +
      attrib <- attr(x, arg_name)
599 +
    }
600 +
601 +
    # arg overwriting (runner masks run_by)
602 +
  } else {
603 +
    if (!is.null(attr(x, arg_name))) {
604 +
      warning(
605 +
        sprintf(
606 +
          "`%1$s` set in run_by() will be ignored in favour of `%1$s` specified in runner() call",
607 +
          arg_name
608 +
        )
609 +
      )
610 +
    }
611 +
612 +
    if (is.character(attrib) && length(attrib) == 1 && attrib %in% names(x)) {
613 +
      attrib <- x[[attrib]]
614 +
    } else if (is.numeric(attrib) || inherits(attrib, c("Date", "POSIXct", "POSIXxt", "POSIXlt"))) {
615 +
      # do nothing
616 +
    } else {
617 +
      stop(
618 +
        sprintf(
619 +
          "`%s` should be either:
620 +
         - column name of `x`
621 +
         - vector of type `numeric`, `Date`, `POSIXct` or `POSIXlt`",
622 +
          arg_name
623 +
        ),
624 +
        call. = FALSE
625 +
      )
626 +
    }
627 +
  }
628 +
629 +
  return(attrib)
630 +
}
631 +
632 +
set_from_attribute_at <- function(x, attrib) {
633 +
  runner_args <- get_parent_call_arg_names()
634 +
  arg_name <- deparse(substitute(attrib))
635 +
636 +
  # no arg overwriting
637 +
  if (!is.null(attr(x, arg_name)) && !arg_name %in% runner_args) {
638 +
    if (length(attr(x, arg_name)) == 1 &&
639 +
        is.character(attr(x, arg_name)) &&
640 +
        attr(x, arg_name) %in% names(x)) {
641 +
642 +
      attrib <- x[[attr(x, arg_name)]]
643 +
    } else if (is.character(attr(x, arg_name))) {
644 +
      stop(
645 +
        sprintf(
646 +
          "`%s` should be either:
647 +
         - column name of `x`
648 +
         - vector of type `numeric`, `Date`, `POSIXct` or `POSIXlt`
649 +
         - character value describing dates sequence step as in `by` argument of `seq.POSIXct`",
650 +
          arg_name
651 +
        ),
652 +
        call. = FALSE
653 +
      )
654 +
    } else {
655 +
      attrib <- attr(x, arg_name)
656 +
    }
657 +
658 +
    # arg overwriting (runner masks run_by)
659 +
  } else {
660 +
    if (!is.null(attr(x, arg_name))) {
661 +
      warning(
662 +
        sprintf(
663 +
          "`%1$s` set in run_by() will be ignored in favour of `%1$s` specified in runner() call",
664 +
          arg_name
665 +
        )
666 +
      )
667 +
    }
668 +
669 +
    if (is.character(attrib) && length(attrib) == 1 && attrib %in% names(x)) {
670 +
      attrib <- x[[attrib]]
671 +
    } else if (length(attrib) == 1 && all(is_datetime_valid(attrib))) {
672 +
      # do nothing
673 +
    } else if (is.numeric(attrib) || inherits(attrib, c("Date", "POSIXct", "POSIXxt", "POSIXlt"))) {
674 +
      # do nothing
675 +
    } else {
676 +
      stop(
677 +
        sprintf(
678 +
          "`%s` should be either:
679 +
         - column name of `x`
680 +
         - vector of type `numeric`, `Date`, `POSIXct` or `POSIXlt`",
681 +
          arg_name
682 +
        ),
683 +
        call. = FALSE
684 +
      )
685 +
    }
686 +
  }
687 +
688 +
  return(attrib)
689 +
}
690 +
691 +
692 +
set_from_attribute_difftime <- function(x, attrib) {
693 +
  runner_args <- get_parent_call_arg_names()
694 +
  arg_name <- deparse(substitute(attrib))
695 +
696 +
  # no arg overwriting
697 +
  if (!is.null(attr(x, arg_name)) && !arg_name %in% runner_args) {
698 +
    if (length(attr(x, arg_name)) == 1 && attr(x, arg_name) %in% names(x)) {
699 +
      attrib <- x[[attr(x, arg_name)]]
700 +
    } else {
701 +
      attrib <- attr(x, arg_name)
702 +
    }
703 +
704 +
  # arg overwriting (runner masks run_by)
705 +
  } else {
706 +
    if (!is.null(attr(x, arg_name))) {
707 +
      warning(
708 +
        sprintf(
709 +
          "`%1$s` set in run_by() will be ignored in favour of `%1$s` specified in runner() call",
710 +
          arg_name
711 +
        )
712 +
      )
713 +
    }
714 +
715 +
    if (is.character(attrib)) {
716 +
      if (length(attrib) == 1 && attrib %in% names(x)) {
717 +
        attrib <- x[[attrib]]
718 +
      } else if (all(is_datetime_valid(attrib))) {
719 +
        # do nothing
720 +
      } else {
721 +
        stop(
722 +
          sprintf(
723 +
            "`%s` is invalid, should be either:
724 +
           - column name of `x`
725 +
           - difftime class or character describing diffitme (see at argument in seq.POSIXt)
726 +
           - numeric or integer vector",
727 +
            arg_name
728 +
          ),
729 +
          call. = FALSE
730 +
        )
731 +
      }
732 +
    } else if (is.numeric(attrib) || is(attrib, "difftime")) {
733 +
      # do nothing
734 +
    } else {
735 +
      stop(
736 +
        sprintf(
737 +
          "`%s` is invalid, should be either:
738 +
           - column name of `x`
739 +
           - difftime class or character describing diffitme (see at argument in `seq.POSIXt`)
740 +
           - numeric or integer vector",
741 +
          arg_name
742 +
        ),
743 +
        call. = FALSE
744 +
      )
745 +
    }
746 +
  }
747 +
748 +
  return(attrib)
749 +
}
750 +
751 +
set_from_attribute_logical <- function(x, attrib) {
752 +
  runner_args <- get_parent_call_arg_names()
753 +
  arg_name <- deparse(substitute(attrib))
754 +
755 +
  # no arg overwriting
756 +
  if (!is.null(attr(x, arg_name)) && !arg_name %in% runner_args) {
757 +
    attrib <- attr(x, arg_name)
758 +
759 +
  # arg overwriting (runner masks run_by)
760 +
  } else if (!is.null(attr(x, arg_name))) {
761 +
    warning(
762 +
      sprintf(
763 +
        "`%1$s` set in run_by() will be ignored in favour of `%1$s` specified in runner() call",
764 +
        arg_name
765 +
      )
766 +
    )
767 +
  }
768 +
769 +
  return(attrib)
770 +
}
771 +
772 +
773 +
#' Access group data in mutate
774 +
#'
775 +
#' Access group data in `dplyr::mutate` after `dplyr::group_by`.
776 +
#' Function created because data available in `dplyr::group_by %>% mutate` scheme
777 +
#' is not filtered by group - in mutate function `.` is still initial dataset.
778 +
#' This function creates `data.frame` using `dplyr::groups` information.
779 +
#' @param x (`data.frame`)\cr
780 +
#'   object which can be `grouped_df` in special case.
781 +
#' @md
782 +
#' @return data.frame filtered by current `dplyr::groups()`
783 +
this_group <- function(x) {
784 +
  if (is(x, "grouped_df")) {
785 +
    attrs <- attributes(x)
786 +
    attrs <- attrs[names(attrs) != "row.names"]
787 +
788 +
    new_env <- new.env(parent = parent.frame(n = 2)$.top_env)
789 +
    df_call <- as.call(
790 +
      append(
791 +
        as.name("data.frame"),
792 +
        lapply(names(x), as.name)
793 +
      )
794 +
    )
795 +
796 +
    x <- eval(df_call, envir = new_env)
797 +
    for (i in seq_along(attrs)) {
798 +
      attr(x, names(attrs)[i]) <- attrs[[i]]
799 +
    }
800 +
  }
801 +
802 +
  return(x)
803 +
}
804 +
Files Coverage
src 93.88%
R/run.R 100.00%
Project Totals (12 files) 95.09%
1
comment: false
2

3
coverage:
4
  status:
5
    project:
6
      default:
7
        target: auto
8
        threshold: 1%
9
    patch:
10
      default:
11
        target: auto
12
        threshold: 1%
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