R/ggtornado.R

In mc2d: Tools for Two-Dimensional Monte-Carlo Simulations

#' @title Draws a Tornado chart as provided by tornado (ggplot version).
#' @name ggtornado
#' @aliases ggtornado
#' @aliases ggtornadounc
#' @description Draws a Tornado chart as provided by tornado. 
#' @usage 
#' ## For class 'tornado'
#' ggtornado(x, 
#'   which=1, 
#'   name=NULL, 
#'   stat=c("median","mean"), 
#'   xlab="method", 
#'   ylab=""
#' )
#' @usage 
#' ## For class 'tornadounc'
#' ggtornadounc(x,
#'   which=1, 
#'   stat="median", 
#'   name=NULL, 
#'   xlab="method", 
#'   ylab=""
#' )
#' @param x A tornado object as provided by the \code{\link{tornado}} function.
#' @param which Which output to print -for multivariates output-.
#' @param name Vector of name of input variables. If NULL, the name will be given from the name of the elements.
#' @param stat The name of the statistics of the output to be considered. For a tornado object: "median" or "mean". For a tornadounc object: the value should match one row name of the tornadounc object. Alternatively, for a tornadounc object, the number of the row may be used.
#' @param xlab Label of the x axis. Default is to use the correlation method used in the tornado object.
#' @param ylab Label of the y axis. Default is empty.
#' @seealso \code{\link{tornado}}
#' @examples
#' data(ec)
#' x <- evalmcmod(ec$modEC2, nsv=100, nsu=100, seed=666)
#' tor <- tornado(x, 7)
#' ggtornado(tor)
#' data(total)
#' ggtornado(tornadounc(total, 10, use="complete.obs"), which=1)
#' @export 
ggtornado <- function(x,which=1,name=NULL,stat=c("median","mean"),xlab="method",ylab="")
{
    val <- x$value[[which]]
    if(is.null(val)) stop("Invalid value for which")
    nc <- ncol(val)
    nr <- nrow(val)
    if(!is.null(name)) {colnames(val) <- (rep(name,nc))[1:nc]}
    
    if(xlab=="method") xlab <- c("Spearman's rho statistic","Kendall's tau statistic","Pearson correlation")[pmatch(x$method,c("spearman","kendall","pearson"))]
    
    #create blank plot
    ggp <- ggplot2::ggplot() +
      ggplot2::ylab(xlab)+
      ggplot2::xlab(ylab)+
      ggplot2::theme_bw()+
      ggplot2::theme(panel.background = ggplot2::element_blank(),
                  panel.border = ggplot2::element_blank(),
                  panel.grid.major = ggplot2::element_blank(),
                  panel.grid.minor = ggplot2::element_blank(),
                  axis.line.x = ggplot2::element_line(linewidth=0.5, colour = "black"),
                  axis.ticks.y = ggplot2::element_blank(),
                  axis.text.y = ggplot2::element_text(size=8))
    
    stat <- match.arg(stat)
    stat <- ifelse(stat=="mean" && nr!=1, 2 ,1)
    val <- val[,order(abs(val[stat,])),drop=FALSE]
    
    
    if(nr==1){
      df <- as.data.frame(t(val))
      ggp <- ggp + 
        ggplot2::geom_bar(data = df, ggplot2::aes(x = rownames(df), y = df[,1]),
                 stat = "identity", 
                 position = "identity",
                 width=0.2)+
        ggplot2::coord_flip()+
        ggplot2::scale_y_continuous(limits = c(-1,1),
                                        breaks=seq(-1,1,0.5),
                                        labels = c("-1","-0.5","0","0.5","1"))+
        ggplot2::scale_x_discrete(limits = rownames(df))+
        ggplot2::geom_point(aes(x=1:nc, y=val),shape="|", size = 8.5)+
        ggplot2::geom_segment(aes(x=0,y=0,xend=nrow(df)+0.2,yend=0))

    } else {
      df <- as.data.frame(t(val))
      ggp <- ggp + 
        ggplot2::geom_bar(data = df, 
                 aes(x = rownames(df), y = df[,stat]),
                 stat = "identity", 
                 position = "identity",
                 width=0.2)+
        ggplot2::coord_flip()+
        ggplot2::scale_y_continuous(limits = c(-1,1),
                           breaks=seq(-1,1,0.5),
                           labels = c("-1","-0.5","0","0.5","1"))+
        ggplot2::scale_x_discrete(limits = rownames(df))
        
        nrow.df <- nrow(df) #assit in drawing the x=0 line
        my <- val[stat,] #instore median or mean val

      if(nr>3){
        xmax <- xmin <- ymax <- ymin <- NULL
        val <- apply(val[3:nr,],2,range)
        df <- as.data.frame(t(val))
        df[,"xminus"] <- c(1:nc-0.1)
        df[,"xplus"] <- c(1:nc+0.1)
        colnames(df) <- c("ymin","ymax","xmin","xmax")
        ggp <- ggp +
          ggplot2::geom_rect(data = df, 
                             ggplot2::aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax))+
          ggplot2::geom_point(aes(x=1:nc, y =val[1,]), shape="|", size=8.5)+               #left        
          ggplot2::geom_point(aes(x=1:nc, y =val[2,]), shape="|", size=8.5)+               #right
          ggplot2::geom_point(aes(x=1:nc, y=my),shape="|", size=8.5)                       #mid
      }
      ggp <- ggp + ggplot2::geom_segment(ggplot2::aes(x=0,y=0,xend=nrow.df+0.2,yend=0))
    }
    #ggp <- ggp + geom_text(aes(x=1:nc, y =-1.4),label = rownames(df),size=2.5)  # add text
    return(ggp)
}

#' @rdname ggtornado
#' @export
ggtornadounc <- function(x,which=1, stat="median", name=NULL, xlab="method", ylab="")

{
  statposs <- rownames(x$value[[which]])
  
  if(is.character(stat)) stat <- pmatch(stat, rownames(x$value[[which]]))
  if(is.na(stat)) stop("stat should match with: ",paste(statposs,collapse=", ")) 
  
  x$value <- list(x$value[[which]][stat,,drop=FALSE])
  ggtornado(x,which=1, stat="median", name=name, xlab=xlab,ylab=ylab)
}