Rolling Average
Seven-day Rolling Average
- Use zoo package to calculate rolling average
dates <- seq(
from = as.Date("2018-01-01", format = "%Y-%m-%d")
, to = as.Date("2020-12-31", format = "%Y-%m-%d")
, by = 1
)
dt <- data.table(
date = rep(dates, 3)
, site = rep(c("A", "B", "C"), each = length(dates))
, daily_volume = rpois(n = length(dates) * 3, lambda = 10)
)
dt <- dt[, daily_volume := daily_volume + as.numeric(date - as.Date("2018-01-01", format = "%Y-%m-%d")) / 60]
library(zoo)
dt <- dt[order(site, date)
][, rolling_avg_7days := rollmean(daily_volume, k = 7, na.pad = TRUE, align = "right"), by = .(site)]
dt <- dt[, period := case_when(
date <= as.Date("2018-08-31", format = "%Y-%m-%d") ~ "I"
, date > as.Date("2020-03-31", format = "%Y-%m-%d") ~ "III"
, TRUE ~ "II"
)]
clrs <- c(
"#333333"
,"#cccccc"
, "#666666"
)
brks <- as.Date(c("2018-01-01", "2018-07-01", "2019-01-01", "2019-07-01", "2020-01-01", "2020-07-01")
, format = "%Y-%m-%d")
p1 <- ggplot(dt, aes(x = date, y = daily_volume, fill = period)) +
geom_bar(stat = "identity", alpha = 0.6) +
## geom_line(data = sm2, aes(x = date_procedure, y = mv7, group = period, color = period), size = 1, alpha = 1) +
geom_line(data = dt, aes(x = date, y = rolling_avg_7days), size = 1, alpha = 0.8) +
scale_x_continuous(breaks=brks, labels = format(brks, "%b %d")) +
scale_fill_manual(values = clrs) +
## scale_color_manual(values = clrs) +
theme(panel.background = element_rect(fill = "transparent")
, plot.background = element_rect(fill = "transparent", color = NA)
, panel.grid.major = element_blank()
, panel.grid.minor = element_blank()
, axis.title.y = element_text(size = 12)
## , legend.background = element_rect(fill = "transparent")
## , legend.box.background = element_rect(fill = "transparent")
, strip.background =element_rect(fill="transparent")
, strip.text.x = element_text(size = 15)
, legend.position = 'top'
, legend.title = element_blank()
## , plot.margin=unit(c(1,2,1,2),"cm")
) +
## theme(axis.text.x = element_text(angle = 45)) +
facet_wrap(~ site, nrow = 3, scales = "free") +
xlab("") +
ylab("Daily Numbers")
## png(filename = "p1.png", width = 12, height = 6, units = "in", res = 300)
p1
Rolling Average with plotly
Rolling Average by Site
sites <- unique(dt$site)
p <- plot_ly(width = 1400, height = 600)
for (i in 1:length(sites)){
p <- p %>% add_trace(
data = dt[site %in% sites[i]]
, x = ~ date
, y = ~ rolling_avg_7days
, name = as.character(sites[i])
, inherit = FALSE
, type = "scatter"
, mode = "lines"
## , hoverinfo = "text"
## , text = ~ str
## , marker = list(symbol = 2, size = 10)
, line = list(alpha = 0.5)
)
}
pPlot of Proportion
dates <- seq(
from = as.Date("2018-01-01", format = "%Y-%m-%d")
, to = as.Date("2020-12-31", format = "%Y-%m-%d")
, by = 1
)
dt <- data.table(
date = rep(dates, 3)
, site = rep(c("A", "B", "C"), each = length(dates))
, daily_volume = rpois(n = length(dates) * 3, lambda = 10)
)
dt <- dt[, yearmonth := format(date, "%Y%m")]
dt <- dt[rep(1:.N, times = daily_volume)]
dt <- dt[, group := sample(c(0, 1), size = nrow(dt), replace = TRUE, prob = c(0.7, 0.3))]
plt_hist_prop(data = dt, x = "yearmonth", yes_var = "group", yes_value = 1, xlabel = "Year Month", no_value = 0)Date Grid Plot
dates <- seq(
from = as.Date("2018-01-01", format = "%Y-%m-%d")
, to = as.Date("2020-12-31", format = "%Y-%m-%d")
, by = 1
)
dt <- data.table(
date = rep(dates, 3)
, site = rep(c("A", "B", "C"), each = length(dates))
, type = sample(c("I", "II", "III"), size = length(dates) * 3, replace = TRUE, prob = c(0.8, 0.15, 0.05))
)
clrs <- c("#EEEEEE"
, "#BBBBBB"
, "#000000"
)
ggplot(dt, aes(x=date, y=site)) +
geom_tile(aes(fill=type, height=(1.2)), size=1) +
scale_y_discrete() +
scale_fill_manual(values = clrs, name = "") +
## scale_x_date(limits = NA) +
labs(y = "site", x = "") +
## facet_wrap( ~ site, ncol = 1) +
theme_bw() +
theme(
## axis.ticks = element_blank()
## , axis.text.y = element_blank()
panel.grid.major = element_blank()
, panel.grid.minor = element_blank()
, panel.background = element_blank()
, strip.background =element_rect(fill="#FFFFFF")
, legend.position="top"
)
R sessionInfo
R version 4.2.0 (2022-04-22) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 20.04.3 LTS
Matrix products: default BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0 LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0
locale: [1] LC_CTYPE=C.UTF-8 LC_NUMERIC=C LC_TIME=C.UTF-8
[4] LC_COLLATE=C.UTF-8 LC_MONETARY=C.UTF-8 LC_MESSAGES=C.UTF-8
[7] LC_PAPER=C.UTF-8 LC_NAME=C LC_ADDRESS=C
[10] LC_TELEPHONE=C LC_MEASUREMENT=C.UTF-8 LC_IDENTIFICATION=C
attached base packages: [1] stats graphics grDevices utils datasets methods base
other attached packages: [1] zoo_1.8-10 Wu_0.0.0.9000 flexdashboard_0.5.2 [4] lme4_1.1-29 Matrix_1.4-0 mgcv_1.8-38
[7] nlme_3.1-152 png_0.1-7 scales_1.2.0
[10] nnet_7.3-16 labelled_2.9.1 kableExtra_1.3.4
[13] plotly_4.10.0 gridExtra_2.3 ggplot2_3.3.6
[16] DT_0.23 tableone_0.13.2 magrittr_2.0.3
[19] lubridate_1.8.0 dplyr_1.0.9 plyr_1.8.7
[22] data.table_1.14.2 rmdformats_1.0.4 knitr_1.39
loaded via a namespace (and not attached): [1] httr_1.4.3 sass_0.4.1 tidyr_1.2.0 jsonlite_1.8.0
[5] viridisLite_0.4.0 splines_4.2.0 bslib_0.3.1 assertthat_0.2.1 [9] highr_0.9 yaml_2.3.5 pillar_1.8.0 lattice_0.20-45
[13] glue_1.6.2 digest_0.6.29 rvest_1.0.2 minqa_1.2.4
[17] colorspace_2.0-3 htmltools_0.5.3 survey_4.1-1 pkgconfig_2.0.3
[21] haven_2.5.0 bookdown_0.27 purrr_0.3.4 webshot_0.5.3
[25] svglite_2.1.0 tibble_3.1.8 farver_2.1.1 generics_0.1.3
[29] ellipsis_0.3.2 withr_2.5.0 klippy_0.0.0.9500 lazyeval_0.2.2
[33] cli_3.3.0 survival_3.2-13 evaluate_0.15 fansi_1.0.3
[37] MASS_7.3-54 forcats_0.5.1 xml2_1.3.3 tools_4.2.0
[41] hms_1.1.1 mitools_2.4 lifecycle_1.0.1 stringr_1.4.0
[45] munsell_0.5.0 compiler_4.2.0 jquerylib_0.1.4 systemfonts_1.0.4 [49] rlang_1.0.4 grid_4.2.0 nloptr_2.0.3 rstudioapi_0.13
[53] htmlwidgets_1.5.4 crosstalk_1.2.0 labeling_0.4.2 rmarkdown_2.14
[57] boot_1.3-28 gtable_0.3.0 DBI_1.1.2 R6_2.5.1
[61] fastmap_1.1.0 utf8_1.2.2 stringi_1.7.8 Rcpp_1.0.9
[65] vctrs_0.4.1 tidyselect_1.1.2 xfun_0.31