#' Export/Plot Actogram with Temperature
#' @export
#' @details Exports actogram plots for each column of a data.frame of tibble with a datetime object.
#' @usage overplot_actogram(df = NULL, overplot = NULL, ld_data = NULL, datetime_column = 1, filename = "actogram.pdf",
#' export = FALSE, width = 12, height = 12, dpi = 800, nrow = 5, ncol = 5)
#'
#' @param df A data.frame or tibble which contains a datetime column and measurement values.
#' @overplot A list or vector containing the values to be overplotted on the actograms. It must be of the same dimensions/binning as the df.
#' @param datetime_column An integer which indicates the column that contains the datetime. Default = 1.
#' @param ld_data A data.frame/Tibble with 2 columns. Column 1 is a datetime object and column 2 is the light/dark indicator. (defult = NULL)
#' @param filename A charater string ending with ".pdf" which customizes the name of the file to be exported. "actogram.pdf" (default)
#' @param export Logical. If FALSE (default), it will open a window with the plots. If TRUE, saves the plots on the current directory in pdf format.
#' @param width a numeric indicating the width of the page of the pdf file. default = 12
#' @param height a numeric indicating height of the page of the pdf file. default = 12
#' @param nrow a numeric indicating how many rows of plots to put in a page. default = 5
#' @param ncol a numeric indicating how many columns of plots to put in a page. default = 5
#' @param autosize Logical. If TRUE, will make the figures bigger as the number of days increase. If FALSE
#' (default) will plot 25 figures per page.
#'
#' @examples
#' overplot_actogram(df = monitor, overplot = monitor[[3]],
#' datetime_column = 1, filename = "actogram.pdf",
#' export = FALSE)
#'
#' @importFrom ggplot2 ggplot geom_tile aes geom_hline geom_vline labs facet_grid scale_x_datetime scale_y_discrete theme element_blank element_text element_line ggsave unit
#' @importFrom gridExtra marrangeGrob
#' @importFrom purrr map
#' @importFrom dplyr group_by mutate case_when arrange ungroup filter if_else
#' @importFrom stringr str_remove
#' @import magrittr
#' @importFrom tidyr gather
#' @importFrom lubridate ddays dminutes
#' @importFrom forcats fct_reorder
#'
overplot_actogram <- function(path = getwd(), df = NULL, overplot = NULL, ld_data = NULL, datetime_column = 1, filename = "actogram.pdf", export = FALSE,
width = 12, height = 12, dpi = 800, nrow = 5, ncol = 5, autosize = FALSE) {
##### Flow Control #####
if (!is.null(df)) {
names(df)[datetime_column] <- "datetime"
df <- df %>% dplyr::select(datetime, everything())
} else (
stop("Must provide a data.frame or tibble.")
)
df$overplot = overplot
if (!is.null(ld_data)) {
ld_data <- dplyr::rename(ld_data, ld = 2)
ld_data <- dplyr::filter(ld_data, ld_data$datetime >= lubridate::ceiling_date(min(ld_data$datetime), unit = "1 day"))
}
#Plan for paralellization
future::plan(future::multisession)
# Make date start at midnight
if (lubridate::hour(min(df$datetime)) != 0) {
df <- dplyr::filter(df, datetime >= lubridate::ceiling_date(min(df$datetime), unit = "1 day"))
}
#Wrangle Data
data <- df %>% make_time_windows(window_size_in_days = 2, window_step_in_days = 1) %>%
tidyr::gather("ind", "value", -c(window,datetime,overplot)) %>%
dplyr::mutate(ind = if_else(ind == 'mean', stringr::str_replace(ind,'mean', '99999'), ind)) %>%
dplyr::mutate(ind = as.numeric(stringr::str_extract(ind,'\\d+'))) %>%
dplyr::group_by(ind, window) %>%
dplyr::mutate(
date = dplyr::case_when(
format(min(datetime), "%d") == format(datetime, "%d") ~ 1,
format(max(datetime) - lubridate::ddays(1), "%d") == format(datetime, "%d") ~ 2,
TRUE ~ 3
),
time = format(datetime, "%H:%M:%S") %>% strptime("%H:%M:%S")
) %>%
dplyr::ungroup() %>%
dplyr::mutate(window = as.numeric(window)) %>%
dplyr::arrange(ind, window, datetime) %>%
dplyr::group_by( window, ind) %>%
dplyr::mutate(value = ((value - min(value, na.rm = TRUE)) / (max(value, na.rm = TRUE) - min(value, na.rm = TRUE)))
) %>%
dplyr::mutate(value = ifelse(is.na(value), 0, value)) %>%
dplyr::ungroup()
# print(unique(data$ind))
if (!is.null(ld_data)) {
data <- dplyr::left_join(data, ld_data, by = "datetime") %>%
dplyr::group_by(date) %>%
dplyr::mutate(
ld = case_when(
ld == 0 | is.na(ld) ~ 1,
ld >= 1 ~ 0
),
ld_y = 0.5
)
}
#Add temperature data
# # normalize the temperatue
# tf_norm <- tf %>%
# dplyr::group_by(window) %>%
# dplyr::mutate(temp = ((temp - min(temp, na.rm = TRUE)) / (max(temp, na.rm = TRUE) - min(temp, na.rm = TRUE)))
# ) %>%
# dplyr::mutate(temp = ifelse(is.na(temp), 0, temp)) %>%
# dplyr::ungroup()
# data <- left_join(data, tf_norm, by = c('window', 'datetime'))
# data
# data <- data %>% ungroup()
#### Parameters for how the plots will look on the page
# print(data)
pl <- furrr::future_map(.x = unique(data$ind),
.f = ~ data %>%
dplyr::filter(date != 3, ind == .x) %>%
ggplot( aes(x = time, y = value/2, height = value)) +
#LD bars
{if (!is.null(ld_data)) geom_tile(aes(x = time, y = ld_y, height = ld), fill = "grey")} +
#Data
geom_tile(fill = "black", na.rm = FALSE) +
geom_line(aes(x = time, y = overplot/max(overplot)),size = 1, col = 'blue', alpha = 0.7) +
labs(title = paste(.x), y = "Days", x = "Clock Time (Hr)") +
geom_hline(yintercept = 0, lty = "solid") +
geom_vline(xintercept = min(data$time)) +
facet_grid(forcats::fct_reorder(factor(window), as.numeric(window)) ~ date, switch = "y", drop = FALSE, scales = "free_y") +
scale_x_datetime(date_labels = "%k", expand = c(0,0)) +
scale_y_continuous(breaks = c(0), labels = c(0)) +
theme(panel.spacing.y = unit(0.05, "lines"),
panel.spacing.x = unit(0, "lines"),
axis.title = element_text(face = "bold", size = 12),
axis.ticks = element_blank(),
axis.line = element_line(),
axis.text.y = element_blank(),
axis.text.x = element_text(size = 12),
strip.background = element_blank(),
strip.placement = "outside",
strip.text.y.left = element_text(angle = 0, size = 12, vjust = 0),
strip.text.x = element_blank(),
plot.margin = unit(c(0,0.5,0,0), "cm"),
panel.border= element_blank(),
panel.background = element_blank(),
plot.title = element_text(hjust = 0.5, vjust = - 0.5)
)
)
if (autosize) {
ncol = ceiling(25/max(data$window, na.rm = TRUE))
nrow = ceiling(25/max(data$window, na.rm = TRUE))
}
ml <- marrangeGrob(pl, ncol = ncol, nrow = nrow)
if (export) {
ggsave(filename, ml, dpi = dpi, width = width, height = height, path = path)
} else {ml}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.