R/plot_plotly.R

In vistime: Pretty Timelines in R

#' Plot the prepared data into Plotly plot
#'
#' @param data the data frame to be plotted (ranges + events), e.g. generated by `visime_data`
#' @param linewidth the width in pixel for the range lines
#' @param title the title for the plot
#' @param show_labels boolean, show labels on events or not
#' @param background_lines number of grey background lines to draw (can be NULL)
#' @importFrom plotly plot_ly
#' @importFrom plotly layout
#' @importFrom plotly add_trace
#' @importFrom plotly add_text
#' @importFrom plotly add_markers
#' @importFrom plotly toRGB
#'
#' @return a plot object generated by `plot_ly`
#' @keywords internal
#' @noRd
#' @examples
#' \dontrun{
#' plot_plotly(data.frame(
#'     event = 1:2, start = as.POSIXct(c("2019-01-01", "2019-01-10")),
#'     end = as.POSIXct(c("2019-01-10", "2019-01-25")),
#'     group = "", tooltip = "", col = "green", fontcol = "black",
#'     subplot = 1, y = 1:2, label = 1:2
#'   ), linewidth = 10, title = "A title", show_labels = TRUE, background_lines = 10
#' )
#' }
plot_plotly <- function(data, linewidth, title, show_labels, background_lines) {

  # 1. Prepare basic plot
  p <- plot_ly(type = "scatter", mode = "lines")

  y_ticks <- tapply(data$y, data$subplot, mean)

  # 2. Divide subplots with horizontal lines
  hline <- function(y = 0) list(type = "line", x0 = 0, x1 = 1, xref = "paper", y0 = y, y1 = y, line = list(color = "grey65", width = 0.5))
  vline <- function(x = 0) list(type = "line", y0 = 0, y1 = 1, yref = "paper", x0 = x, x1 = x, line = list(color = "grey90", width = 0.1))
  horizontal_lines <- lapply(setdiff(seq_len(max(data$y)), data$y), hline)

  # 3. Add vertical lines
  if(!is.null(background_lines)){
    day_breaks <- as.POSIXct(seq(min(c(data$start, data$end)), max(c(data$start, data$end)),
                                 length.out = round(background_lines) + 2), origin = "1970-01-01")
    vertical_lines <- lapply(day_breaks, vline)
  }else{
    vertical_lines <- list()
  }

  p <- layout(p,
              hovermode = "closest",
              plot_bgcolor = "#FCFCFC",
              title = title,
              shapes = append(vertical_lines, horizontal_lines),
              # Axis options:
              xaxis = list(linewidth = 1,  mirror = TRUE,
                           showgrid = is.null(background_lines),
                           gridcolor = "grey90", title = ""),
              yaxis = list(
                linewidth = 1, mirror = TRUE,
                range = c(0, max(data$y) + 1),
                showgrid = F, title = "",
                tickmode = "array",
                tickvals = y_ticks,
                ticktext = as.character(unique(data$group))
              )
  )

  # 4. plot ranges
  range_dat <- data[data$start != data$end, ]

  lw <- ifelse(is.null(linewidth), min(100, 300/max(data$y)), linewidth) # 1-> 100, 2->100, 3->100, 4->70

  if(nrow(range_dat) > 0){
    # draw ranges piecewise
    for (i in seq_len(nrow(range_dat))) {
      toAdd <- range_dat[i, ]

      p <- add_trace(p,
                     x = c(toAdd$start, toAdd$end), # von, bis
                     y = toAdd$y,
                     line = list(color = toAdd$col, width = lw),
                     showlegend = F,
                     hoverinfo = "text",
                     text = toAdd$tooltip
      )
      # add annotations or not
      if (show_labels) {
        p <- add_text(p,
                      x = toAdd$start + (toAdd$end - toAdd$start) / 2, # in der Mitte
                      y = toAdd$y,
                      textfont = list(family = "Arial", size = 14, color = toRGB(toAdd$fontcol)),
                      textposition = "center",
                      showlegend = F,
                      text = toAdd$label,
                      hoverinfo = "none"
        )
      }
    }
  }

  # 5. plot events
  event_dat <- data[data$start == data$end, ]
  if(nrow(event_dat) > 0){
    # alternate y positions for event labels
    event_dat$labelY <- event_dat$y + 0.5 * rep_len(c(1, -1), nrow(event_dat))

    # add all the markers for this Category
    p <- add_markers(p,
                     x = event_dat$start, y = event_dat$y,
                     marker = list(
                       color = event_dat$col, size = 0.7 * lw, symbol = "circle",
                       line = list(color = "black", width = 1)
                     ),
                     showlegend = F, hoverinfo = "text", text = event_dat$tooltip
    )

    # add annotations or not
    if (show_labels) {
      p <- add_text(p,
                    x = event_dat$start, y = event_dat$labelY, textfont = list(family = "Arial", size = 14,
                                                                               color = toRGB(event_dat$fontcol)),
                    textposition ="center", showlegend = F, text = event_dat$label, hoverinfo = "none"
      )
    }

  }


  return(p)
}