R/dumbbell_plot.R

Defines functions dumbbell_plot

Documented in dumbbell_plot

#' dumbbell_plot
#' @param result Bootstrapped result from a compute_phewas function
#' @param colour1 colour for 95%CIs including 1 (default = "#d1d1d1")
#' @param colour2 colour for 95%CIs not including 1 (default = "#0e668b")
#' @return an interactive dumbbell plot powered by plotly
#' @export
dumbbell_plot<- function(result, colour1 = "#d1d1d1", colour2 = "#0e668b", db_type = 'OR') {
  
  if(is.null(result$CI_OR_inf)) return( ggplot(data.frame(x=0,y=0)) + theme_void())
  
  if (db_type == 'OR') {
    dt <- result %>% 
      dplyr::filter(!is.na(CI_OR_inf), !is.na(CODE_LABEL)) %>%
      dplyr::mutate(ci_inf_new = ifelse((CI_OR_inf > 1 & CI_OR_sup > 1) | (CI_OR_inf < 1 & CI_OR_sup < 1), CI_OR_inf, NA),
                    ci_sup_new = ifelse((CI_OR_inf > 1 & CI_OR_sup > 1) | (CI_OR_inf < 1 & CI_OR_sup < 1), CI_OR_sup, NA),
                    CI95 = paste0('[', format(CI_OR_inf, digits = 2, scientific = T),' - ',format(CI_OR_sup, digits = 2, scientific = T),']'))
  } else {
    dt <- result %>% 
      dplyr::filter(!is.na(CI_OR_inf)) %>%
      dplyr::mutate(ci_inf_new = ifelse(p_sup < 0.05 , -log10(p_sup), NA),
                    ci_sup_new = ifelse(p_sup < 0.05 , -log10(p_inf), NA),
                    CI95 = paste0('[', format(p_inf, digits = 2, scientific = T),' - ',format(p_sup, digits = 2, scientific = T),']'),
                    p_sup_log = -log10(p_inf),
                    p_inf_log = -log10(p_sup))
  } 
  
  
  if(!is.null(dt$direction)) {
    dt <- dplyr::mutate(dt, CODE_LABEL = paste0(CODE_LABEL,'_',direction),
                        CODE_LABEL_LAB = paste0(stringr::str_sub(dt$CODE_LABEL, 1, 50),'_',direction))
  } else {
    dt <- dplyr::mutate(dt, CODE_LABEL_LAB = stringr::str_sub(dt$CODE_LABEL, 1, 50))
  } 
  
  dt <- dplyr::mutate(dt, 
                     # CODE_LABEL_LAB = stringr::str_sub(CODE_LABEL, 1, 50),
                      CODE_LABEL_TIP = gsub('(.{1,50})(\\s|$)', '\\1<br>', CODE_LABEL),
                      CODE_LABEL_TIP = gsub('<br>$', '', CODE_LABEL_TIP))
  
  #dt$CODE_LABEL <- stringr::str_sub(dt$CODE_LABEL, 1, 50)
  
  
  
  gg <- ggplot(dt)
  if (db_type == 'OR') {
    gg <- gg + geom_vline(xintercept = 1)
    gg <- gg +  scale_x_log10() 
  } else {
    gg <- gg + geom_vline(xintercept =-log10(0.05))
  }

  
  # gg <- gg + geom_segment(aes(x= 1E-10, xend = CI_OR_inf, y = CODE_LABEL, yend = CODE_LABEL), size = 0.2, linetype = 3,colour ='grey', alpha = 0.8)
  
  if (db_type == 'OR') {
    gg <- gg + geom_segment(aes(x= CI_OR_inf, xend = CI_OR_sup, y = CODE_LABEL_LAB, yend = CODE_LABEL_LAB, text = CODE_LABEL_TIP), colour = colour1 , size = 1)
    gg <- gg + geom_point(aes(x= CI_OR_inf, y = CODE_LABEL_LAB, text = CODE_LABEL_TIP) , colour = colour1)
    gg <- gg + geom_point(aes(x= CI_OR_sup, y = CODE_LABEL_LAB, text = CODE_LABEL_TIP), colour = colour1)
  } else {
    gg <- gg + geom_segment(aes(x= p_inf_log, xend = p_sup_log, y = CODE_LABEL_LAB, yend = CODE_LABEL_LAB, text = CODE_LABEL_TIP), colour = colour1 , size = 1)
    gg <- gg + geom_point(aes(x= p_inf_log, y = CODE_LABEL_LAB, text = CODE_LABEL_TIP) , colour = colour1)
    gg <- gg + geom_point(aes(x= p_sup_log, y = CODE_LABEL_LAB, text = CODE_LABEL_TIP), colour = colour1)
  }

  #gg <- gg + geom_segment_interactive(aes(x= ci_inf_new, xend =ci_sup_new, y = CODE_LABEL, yend = CODE_LABEL, tooltip = ci_print), colour = colour2 ,size = 1)
  #gg <- gg + geom_point_interactive(aes(x= ci_inf_new, y = CODE_LABEL, tooltip = ci_print) , colour = colour2)
  #gg <- gg + geom_point_interactive(aes(x= ci_sup_new, y = CODE_LABEL, tooltip = ci_print), colour = colour2)
  
  if (db_type == 'OR') {
    gg <- gg + geom_segment(aes(x= ci_inf_new, xend =ci_sup_new, y = CODE_LABEL_LAB, yend = CODE_LABEL_LAB, label = CI95, text = CODE_LABEL_TIP), colour = colour2 ,size = 1)
    gg <- gg + geom_point(aes(x= ci_inf_new, y = CODE_LABEL_LAB, label = CI95, text = CODE_LABEL_TIP) , colour = colour2)
    gg <- gg + geom_point(aes(x= ci_sup_new, y = CODE_LABEL_LAB, label = CI95, text = CODE_LABEL_TIP), colour = colour2)
  } else if (sum(is.na(dt$ci_inf_new)) < nrow(dt)) {
    gg <- gg + geom_segment(aes(x= ci_inf_new, xend =ci_sup_new, y = CODE_LABEL_LAB, yend = CODE_LABEL_LAB, label = CI95, text = CODE_LABEL_TIP), colour = colour2 ,size = 1)
    gg <- gg + geom_point(aes(x= ci_inf_new, y = CODE_LABEL_LAB, label = CI95, text = CODE_LABEL_TIP) , colour = colour2)
    gg <- gg + geom_point(aes(x= ci_sup_new, y = CODE_LABEL_LAB, label = CI95, text = CODE_LABEL_TIP), colour = colour2)
  }

  
  
  gg <- gg + labs(x=NULL, y=NULL)
  gg <- gg + theme_bw()
  #gg <- gg + theme(plot.background=element_rect(fill="#f7f7f7"))
  #gg <- gg + theme(panel.background=element_rect(fill="#f7f7f7"))
  gg <- gg + theme(panel.grid.minor=element_blank())
  gg <- gg + theme(panel.grid.major.y=element_blank())
  gg <- gg + theme(panel.grid.major.x=element_blank())
  gg <- gg + theme(axis.ticks=element_blank())
  gg <- gg + theme(legend.position="top")
  gg <- gg + theme(panel.border=element_blank())
  if (db_type == 'OR') {
    gg <- gg + xlab('95%CI of Odds Ratio (bootstraped, log scale)')
  } else {
    gg <- gg + xlab('95% CI of P values (bootstrapped)')
  }
 

  
  gg
}
aneuraz/multiWAS documentation built on July 29, 2017, 3:39 a.m.