Commit ⋅ gogonzo/runner

#'   f = mean
#' )
#' @md
#' @rdname runner
#' @importFrom methods is
#' @export
runner <- function(
runner <- function (
  x,
  f = function(x) x,
  k = integer(0),
  lag = integer(1),
  idx = integer(0),
  at = integer(0),
  na_pad = FALSE,
  type = "auto",
  ...
  ) {
  UseMethod("runner", x)
}

#' @rdname runner
#' @export
runner.data.frame <- function(
  x,
  f = function(x) x,
  k = integer(0),
  lag = integer(1),
  idx = integer(0),
  at = integer(0),
  na_pad = FALSE,
  type = "auto",
  ...
  ) {

  # dplyr::group_by exception
  x <- this_group(x)

  # set arguments from attrs set by run_by
  k <- set_from_attribute_difftime(x, k) # no deep copy
  lag <- set_from_attribute_difftime(x, lag)
  idx <- set_from_attribute_index(x, idx)
  at <- set_from_attribute_at(x, at)
  na_pad <- set_from_attribute_logical(x, na_pad)

  if (any(is.na(k))) {
    stop("Function doesn't accept NA values in k vector");
  }
  if (any(is.na(lag))) {
    stop("Function doesn't accept NA values in lag vector");
  }
  if (any(is.na(idx))) {
    stop("Function doesn't accept NA values in idx vector");
  }
  if (!is(f, "function")) {
    stop("f should be a function")
  }

  # use POSIXt.seq
  at  <- seq_at(at, idx)
  k   <- k_by(k,   if (length(at) > 0) at else idx, "k")
  lag <- k_by(lag, if (length(at) > 0) at else idx, "lag")

  w <- window_run(
    x = seq_len(nrow(x)),
    k = k,
    lag = lag,
    idx = idx,
    at = at,
    na_pad = na_pad
  )

  res <- sapply(w, function(ww) {
    if (length(ww) == 0) {
      NA
    } else {
      f(x[ww, ], ...)
    }
  })

  return(res)
}

#' @rdname runner
#' @export
runner.default <- function(
  x,
  f = function(x) x,
  k = integer(0),

@@ -198,16 +277,13 @@

  }


  at <- seq_by(at, idx)
  # use POSIXt.seq
  at <- seq_at(at, idx)
  k <- k_by(k, if (length(at > 0)) at else idx, "k")
  lag <- k_by(lag, if (length(at > 0)) at else idx, "lag")

  w <- window_run(
    x = if (is.data.frame(x) || is.matrix(x)) {
      seq_len(nrow(x))
    } else {
      x
    },
    x = x,
    k = k,
    lag = lag,
    idx = idx,

@@ -215,16 +291,7 @@

    na_pad = na_pad
  )

  if (is.data.frame(x) || is.matrix(x)) {
    res <- sapply(w, function(ww) {
      if (length(ww) == 0) {
        NA
      } else {
        f(x[ww, ], ...)
      }
    })

  } else if (type != "auto") {
  if (type != "auto") {
    n <- length(w)
    res <- vector(mode = type, length = n)
    for (i in seq_len(n)) {

@@ -235,6 +302,7 @@

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 @@

    )
  }


  return(res)
}

#' Creates sequence for at as time-unit-interval
#'
#' Creates sequence for at as time-unit-interval
#' @param at object from runner
#' @param idx object from runner
seq_by <- function(at, idx) {
  if ((is.character(at) &&
       length(at) == 1)) {
get_parent_call_arg_names <- function() {
  cl <- sys.call(-2)
  f <- get(as.character(cl[[1]]), mode="function", sys.frame(-2))
  cl <- match.call(definition=f, call=cl)
  names(cl)
}

    if (length(idx) == 0) {
      stop(
        sprintf("`idx` can't be empty while specifying at as time interval")
      )
    }
is_datetime_valid <- function(x) {
  all(
    grepl("^(sec|min|hour|day|DSTday|week|month|quarter|year)$", x = x) |
      grepl("^-*[0-9]+ (sec|min|hour|day|DSTday|week|month|quarter|year)s", x = x)
  )

    if (inherits(idx, c("Date", "POSIXct", "POSIXxt", "POSIXlt"))) {
      at <- if (grepl("^-", at)) {
        seq(max(idx), min(idx), by = at)
      } else {
        seq(min(idx), max(idx), by = at)
      }
    } else {
      stop("To specify at as time interval character `idx` can't be empty")
    }
  }
  return(at)
}


#' Converts k and lag from time-unit-interval to int
#'
#' Converts k and lag from time-unit-interval to int
#' @param k object from runner
#' @param idx object from runner
#' @inheritParams runner
#' @param param name of the parameter to be printed in error message
#' @examples
#' k <-  "1 month"

@@ -296,7 +350,13 @@

      reformat_k(k, only_positive = FALSE)
    }

    from <- if (length(idx) == length(k) && length(k) != 1) {
    from <- if (length(k) != 1) {
      if (length(idx) == 0) {
        stop(
          sprintf("`idx` can't be empty while specifying `%s` as time interval", param)
        )
      }

      mapply(
        FUN = function(x, y) {
          seq(x, by = y, length.out = 2)[2]

@@ -307,7 +367,7 @@

    } else if (length(k) == 1) {
      if (length(idx) == 0) {
        stop(
          sprintf("`idx` can't be empty while specifying %s='%s'", param, k)
          sprintf("`idx` can't be empty while specifying `%s` as time interval", param)
        )
      }


@@ -318,17 +378,37 @@

      )
    }

    return(as.numeric(idx) - from)
    return(as.integer(idx) - from)

  } else if (is(k, "difftime")) {
    k <- if (param == "k") {
      if (any(k < 0)) {
        stop("`k` can't be negative.")
      }
      abs(k)
    } else {
      k
    }

    if (length(idx) == 0) {
      stop(
        sprintf("`idx` can't be empty while specifying %s as difftime", param)
      )
    }
    from <- idx - k
    k <- as.integer(idx) - as.integer(from)
  }

  return(k)
}



#' Formats time-unit-interval to valid for runner
#'
#' Formats time-unit-interval to valid for runner
#' @param k (k or lag) object from runner to be formatted
#' @param only_positive for k is TRUE, for lag is FALSE
#' @param only_positive for \code{k} is \code{TRUE}, for \code{lag} is \code{FALSE}
#' @examples
#' runner:::reformat_k("1 days")
#' runner:::reformat_k("day")

@@ -349,3 +429,376 @@

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	1,176	1,104	72	93.88%
R/run.R	290	290	0	100.00%
Project Totals (12 files)	1,466	1,394	72	95.09%

View CI Build Download

comment: false

coverage:
  status:
    project:
      default:
        target: auto
        threshold: 1%
    patch:
      default:
        target: auto
        threshold: 1%

Read the docs

Interact now

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.

SVG

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.

SVG

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.

SVG

Learn more about the coverage sunburst graph

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	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)) {

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	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	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

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),

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")

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%

Navigation	Overlay
`t` Navigate files	`h` Toggle hits
`y` Change url to tip of branch	`m` Toggle misses
`b / v` Jump to prev/next hit line	`p` Toggle partial
`z / x` Jump to prev/next missed or partial line	`1..9` Toggle flags
`shift + o` Open current page in GitHub	`a` Toggle all on
`/ or ?` Show keyboard shortcuts dialog	`c` Toggle context lines or commits

Updating our web app