R/print_xpose_plot.R

Defines functions print.xpose_plot

Documented in print.xpose_plot

#' Draw an xpose_plot object
#' 
#' @description This function explicitly draw an xpose_plot and interprets keywords 
#' contained in labels.
#' 
#' @param x An \code{xpose_plot} object.
#' @param page The page number to be drawn. Can be specified as vector or range 
#' of integer values.
#' @param ... Options to be passed on to the ggplot2 print method.
#' 
#' @method print xpose_plot
#' @examples
#' my_plot <- dv_vs_ipred(xpdb_ex_pk) +
#'             labs(title = 'A label with keywords: @nind individuals & @nobs observations')

#' # Using the print function
#' print(my_plot)
#' 
#' # Or simply by writting the plot object name
#' my_plot
#' 
#' @export
print.xpose_plot <- function(x, page, ...) {
  
  # Parse template titles
  if (is.xpose.plot(x)) {
    # Add prefix to title subtitle, caption and tags
    x$labels$title    <- append_suffix(x$xpose, x$labels$title, 'title')
    x$labels$subtitle <- append_suffix(x$xpose, x$labels$subtitle, 'subtitle')
    x$labels$caption  <- append_suffix(x$xpose, x$labels$caption, 'caption')
    
    if (utils::packageVersion('ggplot2') >= '3.0.0') {
      x$labels$tag      <- append_suffix(x$xpose, x$labels$tag, 'tag')
    }
    
    # Get the mapping variables keywords and values
    var_map <- x$mapping %>% 
      as.character() %>%
      stringr::str_remove(pattern = "^~") %>% 
      
      ## Improve parsing since we now have to use the .data[["var"]] format in aes()
      ifelse(stringr::str_detect(., "\\.data\\[\\[\"\\w+\"]]"), 
             yes = stringr::str_remove_all(., "(\\.data\\[\\[\")|(\"]])"),
             no  = .) %>% 
      purrr::set_names(names(x$mapping))
    
    # Process the keywords
    x$labels <- x$labels %>% 
      purrr::map_if(stringr::str_detect(., '@'),
                    .f = parse_title, xpdb = x$xpose,
                    problem = x$xpose$problem, quiet = x$xpose$quiet,
                    ignore_key = c('page', 'lastpage'),
                    extra_key = c('plotfun', 'timeplot', names(var_map)), 
                    extra_value = c(x$xpose$fun, 
                                    format(Sys.time(), "%a %b %d %X %Z %Y"), 
                                    var_map))
  }
  
  # Print multiple pages
  if (class(x$facet)[1] %in% c('FacetWrapPaginate', 'FacetGridPaginate')) {
    
    # Get total number of pages
    #page_tot <- n_pages(repair_facet(x))
    page_tot <- n_pages(x)
    
    # Get and check the page number to be drawn
    if (!missing(page)) {
      page_2_draw <- page
    } else if (!is.null(x$facet$params$page)) {
      page_2_draw <- x$facet$params$page
    } else {
      page_2_draw <- 1:page_tot
    }
    
    if (any(page_2_draw > page_tot)) {
      page_2_draw <- page_2_draw[page_2_draw <= page_tot]
      if (length(page_2_draw) == 0) {
        stop('All `page` element exceeded the total (', page_tot, ') number of pages.', call. = FALSE)  
      }
      warning('`page` contained elements exceeding the total (', page_tot, ') number of pages. These were ignored.',
              call. = FALSE)
    }
    
    # Prevent issue with facet_repair when page = NULL
    x$facet$params$page <- page_2_draw
    
    # Begin multiple page ploting
    n_page_2_draw <- length(page_2_draw)
    
    if (interactive() && !x$xpose$quiet) {
      message('Rendering ', n_page_2_draw, ' selected page(s) out of ', page_tot, '.')
    }
    
    if (n_page_2_draw == 1) {
      x %>% 
        paginate(page_2_draw, page_tot) %>% 
        #repair_facet() %>% 
        print.ggplot(...)
    } else {
      if (interactive() && !x$xpose$quiet) {
        pb <- utils::txtProgressBar(min = 0, max = n_page_2_draw, 
                                    style = 3)   # Create progress bar
      }
      for (p in seq_along(page_2_draw)) {
        x$facet$params$page <- page_2_draw[p]
        x %>% 
          paginate(page_2_draw[p], page_tot) %>% 
          #repair_facet() %>% 
          print.ggplot(...)
        if (interactive() && !x$xpose$quiet) {
          utils::setTxtProgressBar(pb, value = p) # Update progress bar
        }
      }
      if (interactive() && !x$xpose$quiet) close(pb)
      
      # Prevent ggforce from droping multiple pages value
      x$facet$params$page <- page_2_draw
    }
  } else {
    if (!missing(page)) warning('Faceting not set. Ignoring `page` argument.', call. = FALSE)
    
    # Warn for big plots
    panel_tot <- n_panels(x)
    
    if (panel_tot > 20) {
      msg(c('The faceting resulted in ', panel_tot, 
            ' panels. The plot may take a while to render.'), 
          quiet = x$xpose$quiet)
    }
    
    # Print without multiple pages
    x %>% 
      paginate(page_2_draw = 1, page_tot = 1) %>% 
      #repair_facet() %>% 
      print.ggplot(...)
  }
}

#' Import print ggplot method
#' @keywords internal
print.ggplot <- get('print.ggplot', envir = asNamespace('ggplot2'))


# Add page number to pages
paginate <- function(plot, page_2_draw, page_tot) {
  plot$labels <- plot$labels %>% 
    purrr::map_if(.p = ~!is.null(.) && stringr::str_detect(., '@(page|lastpage)'),
                  .f = parse_title, xpdb = plot$xpose,
                  problem = plot$xpose$problem, quiet = plot$xpose$quiet,
                  extra_key = c('page', 'lastpage'), 
                  extra_value = c(as.character(page_2_draw), page_tot))
  plot
}


# Temporary fix for ggforce facet_wrap_paginate (may)
# repair_facet <- function(x) {
#   if (class(x$facet)[1] == 'FacetWrapPaginate' && 
#       !'nrow' %in% names(x$facet$params)) {
#     x$facet$params$nrow <- x$facet$params$max_row
#   }
#   x
# }

# Calculate the total number of pages
n_pages <- function(plot) {
  if (utils::packageVersion('ggplot2') <= '2.2.1') {
    page <- ggplot_build(plot)$layout$panel_layout$page
  } else {
    page <- ggplot_build(plot)$layout$layout$page
  }
  if (!is.null(page)) {
    max(page)
  } else {
    0L
  }
}

# Calculate the total number of panels
n_panels <- function(plot) {
  if (utils::packageVersion('ggplot2') <= '2.2.1') {
    page <- ggplot_build(plot)$layout$panel_layout
  } else {
    page <- ggplot_build(plot)$layout$layout
  }
  if (!is.null(page)) {
    nrow(page)
  } else {
    0L
  }
}
UUPharmacometrics/xpose documentation built on Feb. 4, 2024, 7:21 a.m.