diagnostics.R (prophet-1.0) | : | diagnostics.R (prophet-1.1) | ||
---|---|---|---|---|

skipping to change at line 350 | skipping to change at line 350 | |||

#' | #' | |||

#' @return Dataframe with columns horizon and name, the rolling mean of x. | #' @return Dataframe with columns horizon and name, the rolling mean of x. | |||

#' | #' | |||

#' @importFrom dplyr "%>%" | #' @importFrom dplyr "%>%" | |||

#' @keywords internal | #' @keywords internal | |||

rolling_mean_by_h <- function(x, h, w, name) { | rolling_mean_by_h <- function(x, h, w, name) { | |||

# Aggregate over h | # Aggregate over h | |||

df <- data.frame(x=x, h=h) | df <- data.frame(x=x, h=h) | |||

df2 <- df %>% | df2 <- df %>% | |||

dplyr::group_by(h) %>% | dplyr::group_by(h) %>% | |||

dplyr::summarise(mean = mean(x), n = dplyr::n()) | dplyr::summarise(sum = sum(x), n = dplyr::n()) | |||

xm <- df2$mean | xs <- df2$sum | |||

ns <- df2$n | ns <- df2$n | |||

hs <- df2$h | hs <- df2$h | |||

res <- data.frame(horizon=c()) | trailing_i <- length(hs) | |||

res[[name]] <- c() | x_sum <- 0 | |||

n_sum <- 0 | ||||

# We don't know output size but it is bounded by length(hs) | ||||

res_x <- vector("double", length=length(hs)) | ||||

# Start from the right and work backwards | # Start from the right and work backwards | |||

i <- length(hs) | for(i in length(hs):1) { | |||

while (i > 0) { | x_sum <- x_sum + xs[i] | |||

# Construct a mean of at least w samples | n_sum <- n_sum + ns[i] | |||

n <- ns[i] | while (n_sum >= w) { | |||

xbar <- xm[i] | # Include points from the previous horizon. All of them if still | |||

j <- i - 1 | # less than w, otherwise weight the mean by the difference | |||

while ((n < w) & (j > 0)) { | excess_n <- n_sum - w | |||

# Include points from the previous horizon. All of them if still less | excess_x <- excess_n * xs[i]/ ns[i] | |||

# than w, otherwise just enough to get to w. | res_x[trailing_i] <- (x_sum - excess_x) / w | |||

n2 <- min(w - n, ns[j]) | x_sum <- x_sum - xs[trailing_i] | |||

xbar <- xbar * (n / (n + n2)) + xm[j] * (n2 / (n + n2)) | n_sum <- n_sum - ns[trailing_i] | |||

n <- n + n2 | trailing_i <- trailing_i - 1 | |||

j <- j - 1 | ||||

} | ||||

if (n < w) { | ||||

# Ran out of horizons before enough points. | ||||

break | ||||

} | } | |||

res.i <- data.frame(horizon=hs[i]) | ||||

res.i[[name]] <- xbar | ||||

res <- rbind(res.i, res) | ||||

i <- i - 1 | ||||

} | } | |||

# R handles subsetting weirdly | ||||

if(trailing_i == 0) { | ||||

res_h <- hs | ||||

} else { | ||||

res_h <- hs[-(1:trailing_i)] | ||||

res_x <- res_x[-(1:trailing_i)] | ||||

} | ||||

res <- data.frame(horizon=res_h) | ||||

res[[name]] <- res_x | ||||

return(res) | return(res) | |||

} | } | |||

#' Compute a rolling median of x, after first aggregating by h | #' Compute a rolling median of x, after first aggregating by h | |||

#' | #' | |||

#' Right-aligned. Computes a single median for each unique value of h. Each medi an | #' Right-aligned. Computes a single median for each unique value of h. Each medi an | |||

#' is over at least w samples. | #' is over at least w samples. | |||

#' | #' | |||

#' For each h where there are fewer than w samples, we take samples from the pre vious h, | #' For each h where there are fewer than w samples, we take samples from the pre vious h, | |||

# moving backwards. (In other words, we ~ assume that the x's are shuffled with in each h.) | # moving backwards. (In other words, we ~ assume that the x's are shuffled with in each h.) | |||

End of changes. 6 change blocks. | ||||

25 lines changed or deleted | | 32 lines changed or added |