R/ggsplom.R

In abnormally-distributed/abdisttools: Random Functions for Personal Use

#' SCatterplot Matrix with ggplot2
#'
#'
#' @inherit GGally::scatmat
#' @param rug Whether a rug of data points should be plotted in margins. Default is TRUE.
#' @param rug.color Color of data rug
#' @param point_size The size of the scatterplot points
#' @param line.color Color of density lines. Ignored if color = TRUE since that generates its own assortment of colors.
#' @param point.color Color of points. Ignored if color = TRUE since that generates its own assortment of colors.
#' @export
#' @examples
#' ggsplom()

ggsplom = function (data, 
                    columns = 1:ncol(data), 
                    color = NULL, 
                    alpha = .7, 
                    point_size = .9, 
                    rug = TRUE, 
                    rug.color = "white", 
                    line.color = "red", 
                    point.color = "#00DDFF")
  {
    data <- GGally:::upgrade_scatmat_data(data)
    data.choose <- data[columns]
    dn <- data.choose[sapply(data.choose, is.numeric)]
    if (ncol(dn) == 0) {
      stop("All of your variables are factors. Need numeric variables to make scatterplot matrix.")
    }
    else {
      ltdata.new <- lowertriangle(data, columns = columns, color = color)
      r <- ggplot(ltdata.new, mapping = aes_string(x = "xvalue", 
                                                   y = "yvalue")) + 
        theme(axis.title.x = element_blank(), axis.title.y = element_blank()) + 
        facet_grid(ylab ~  xlab, scales = "free") + 
        theme(aspect.ratio = 1)
      
      if (is.null(color)) {
        densities <- do.call("rbind", lapply(1:ncol(dn), 
                                             function(i) {
                                               data.frame(xlab = names(dn)[i], ylab = names(dn)[i], 
                                                          x = dn[, i])
                                             }))
        for (m in 1:ncol(dn)) {
          j <- subset(densities, xlab == names(dn)[m])
          
          r <- r + stat_density(aes(x = x, y = ..scaled.. * 
                                      diff(range(x)) + min(x)), data = j, position = "identity", 
                                      geom = "line", 
                                      color = line.color, 
                                      bw = "SJ", 
                                      adjust = 2, 
                                      kernel = "optcosine", 
                                      n = 1024,
                                      size = 1)
        }
        r <- r + geom_point(alpha = alpha, na.rm = TRUE, size = point_size, color = point.color)
        
        if (isTRUE(rug)) {
          
          r =  r + geom_rug(alpha = .65, color = rug.color)
        } 
        
        return(r)
      }
      else {
        densities <- do.call("rbind", lapply(1:ncol(dn), 
                                             function(i) {
                                               data.frame(xlab = names(dn)[i], ylab = names(dn)[i], 
                                                          x = dn[, i], colorcolumn = data[, which(colnames(data) == 
                                                                                                    color)])
                                             }))
        for (m in 1:ncol(dn)) {
          j <- subset(densities, xlab == names(dn)[m])
          r <- r + stat_density(aes_string(x = "x", 
                                           y = ..scaled.. * diff(range(x), 
                                           bw = "SJ", 
                                           adjust = 2, 
                                           kernel = "optcosine", 
                                           n = 1024) + 
                                             min(x), 
                                             colour = "colorcolumn"), 
                                             data = j, 
                                             position = "identity", 
                                             size = 1, 
                                             geom = "line")
        }
        r <- r + geom_point(data = ltdata.new, aes_string(colour = "colorcolumn"), alpha = alpha, na.rm = TRUE, size = point_size)
        
        if (isTRUE(rug)) {
          
          r = r + geom_rug(alpha = .65, color = rug.color)
        } 
        
        return(r)
      }
    }
  }