R/overplot_actogram.R

In edpclau/circadian-dynamics: Period and Rythm Analysis of Timeseries Data

#' 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}

}