R/helper_timerelated2.R

In mtb: My Toolbox for Assisting Document Editing and Data Presenting

#  Copyright (C) 2020 Y Hsu <yh202109@gmail.com>
#
#  This program is free software: you can redistribute it and/or modify
#  it under the terms of the GNU General Public license as published by
#  the Free software Foundation, either version 3 of the License, or
#  any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
#  GNU General Public License for more details
#
#  You should have received a copy of the GNU General Public license
#  along with this program. If not, see <https://www.gnu.org/license/>

############################################################
#' Plot labeled events
#'
#' @description
#' Create a plot for events with labels
#'
#' @importFrom ggplot2 ggplot aes geom_segment geom_label xlab ylab arrow labs geom_rect geom_hline geom_vline theme element_blank geom_text geom_point coord_flip
#' @importFrom stats aggregate
#'
#' @param dt a \code{data.frame} with the following columns
#' \itemize{
#'   \item{id}{for ID of each group}
#'   \item{\code{idn}}{for order of ID}
#'   \item{start}{for starting time}
#'   \item{end}{for ending time with arrow head}
#'   \item{label}{for labeling the starting time}
#'   \item{\code{labelend}}{for labeling the ending time of a interval}
#'   \item{type}{for event type as one of p (point), i (interval), b (box)}
#'   \item{color}{a string for event color}
#' }
#' @param xlab A string for the x-axis title
#' @param anchor A Boolean value for the vertical lines linking \code{start} to the x-axis
#' @param compact A Boolean value for reducing the vertical spacing when applicable
#'
#' @return a plot
#'
#' @examples
#' library(ggplot2)
#' dt = data.frame( id=paste('member',c(rep(c(1,2,3),each=3),3),sep=""),
#' idn=c(rep(1,3),rep(-1,3), rep(2,4)),
#' start=1800*c(0,1,2, 0.5, 1.2, 3, 1,2,3,4),
#' end=1800*c(2,NA,3, 2, 6, NA, 2,2.5,3, 3.5),
#' label=c(paste('event-',seq(1,10),sep='')),
#' labelend=c('','','?',')','','','','','>','X'),
#' type=c('b', 'p', 'i','i','p','p','p','b','i','i' ),
#' color=c('stove', 'oven', 'oven','oven','stove','oven','oven','other','stove','oven' )
#'  )
#' time_plot_event( dt )
#'
#' @export

time_plot_event <- function( dt, xlab='Time', anchor=TRUE, compact=FALSE ){
  dt$start = mtb_dt_toPOSIXct(dt$start)
  dt$end = mtb_dt_toPOSIXct(dt$end)
  dt=dt[!is.na(dt$start),]
  lstn1=c('id','idn','start','end','label','labelend','type', 'color')
  lstn2=colnames(dt)
  if( length(intersect(lstn1, lstn2))!=length(lstn1) ){stop('There were missing columns')}
  dt2=unique(dt[,c('id','idn')])
  if(dim(dt2)[1] != length(unique(dt2$id)) | dim(dt2)[1] != length(unique(dt2$id))){dt2$idn=as.numeric(as.factor(dt2$id));dt2=unique(dt2)}
  dt2=dt2[order(dt2$idn, decreasing=TRUE),]
  dt$id = factor(dt$id, levels=dt2$id)
  dt$idn = NULL
  dt=merge(dt, dt2, by='id', all.x=TRUE)
  dt=dt[order(dt$idn, dt$start),]
  dt$yloc=seq(1, length(dt$id))
  dt$type[is.na(dt$end)]='p'
  dt$type[dt$start==dt$end]='p'
  dt$end[dt$type=='p']=dt$start[dt$type=='p']
  xlab=as.character(xlab)
  if( xlab=="" ){xlab='Time'}
  if(compact==TRUE){
    dt$end[dt$type=='p']=dt$start[dt$type=='p']+diff(range(c(dt$start, dt$end)))/6
    for(idx in dim(dt2)[1]:1){
      fdt=dt[dt$idn==dt2$idn[idx],]
      if(nrow(fdt)>1){
        fyl=aggregate(fdt$end, list(fdt$yloc), FUN=max)
        for(idx2 in 2:nrow(fdt) ){
          if( fdt$start[idx2]>min(fyl$x) ){
            fdt$yloc[idx2]=min(fyl$Group.1[fyl$x<=fdt$start[idx2]])
            fyl=aggregate(fdt$end, list(fdt$yloc), FUN=max)
          }
        }
        dt[dt$idn==dt2$idn[idx],'yloc']=fdt$yloc
      }
    }
    dt=dt[order(dt$idn, dt$yloc, dt$start),]
  }
  dt$yloc=as.numeric(as.factor(dt$yloc))
  dt$yloc2=dt$yloc+(dt$type=='i')*0.2
  yh=dt$yloc[c(diff(dt$idn)!=0, FALSE)]+0.5
  yl=aggregate(dt$yloc, list(dt$id), FUN=mean)

  p = ggplot(dt, aes_string(color='color'))+ geom_hline(yintercept=yh)+xlab(xlab)+
    theme(
      panel.grid.major.y=element_blank(), panel.grid.minor.y=element_blank(),
      panel.grid.major.x=element_blank(), panel.grid.minor.x=element_blank(),
          axis.ticks.y=element_blank(),axis.title.y=element_blank())+
    scale_y_continuous(breaks=yl$x, labels=yl$Group.1)
  if(anchor==TRUE){
    p=p+geom_point(aes_string(x='start', y='0'), alpha=0.7)+
      geom_segment(dt,mapping=aes_string(x='start', xend='start', y='0', yend='yloc'), lwd=1, alpha=0.5, color='gray', lty=1)
  }
  if(sum(dt$type=='b')>0){
    p=p+geom_rect(dt[dt$type=='b',],mapping=aes_string(xmin='start', xmax='end', ymin='yloc+0.25', ymax='yloc-0.25'), alpha=0.5, fill='gray', linejoin='round')
  }
  if(sum(dt$type=='i')>0){
    p=p+geom_segment(dt[dt$type=='i',],mapping=aes_string(x='start', xend='end', y='yloc', yend='yloc'), lwd=3, alpha=0.3)+
      geom_point(dt[dt$type=='i',],mapping=aes_string(x='start', y='yloc'), size=4, alpha=0.5)+
      geom_text(dt[dt$type=='i',],mapping=aes_string(x='end',y='yloc',label='paste(labelend)'), hjust=1, vjust=0.5, size=4, fontface='bold')
  }
  if(sum(dt$type=='p')>0){
    p=p+geom_point(dt[dt$type=='p',],mapping=aes_string(x='start', y='yloc'), alpha=0.7, size=4)
  }
  p+geom_text(aes_string(x='start',y='yloc2',label='paste(" ",label)', hjust=0, vjust=0))
}