R/utils.r

In MissingDataGUI: A GUI for Missing Data Exploration

if(getRversion() >= '2.15.1') globalVariables(c("observation", "variable","Reordered_Observation","Missing","Missings","x1","x2","y1","y2"))

## The default color palette for MissingDataGUI
##
## Service the colorblind.
## \url{http://www.cookbook-r.com/Graphs/Colors_(ggplot2)/}
## @name cbPalette
## @docType data
## @noRd
##
#cbPalette = c("#56B4E9", "#E69F00", "#009E73", "#000000")
##' Change the discrete color scale for the plots generated by ggplot2
##'
##' @param ... parameters passed into the function
##' @return NULL
##' @export
##'
#scale_colour_discrete = function(...) scale_colour_manual(values=cbPalette)
scale_colour_discrete = function(...) scale_colour_manual(values=c("#56B4E9", "#E69F00"))
##' Change the discrete fill scale for the plots generated by ggplot2
##'
##' @param ... parameters passed into the function
##' @return NULL
##' @export
##'
#scale_fill_discrete = function(...) scale_fill_manual(values=cbPalette)
scale_fill_discrete = function(...) scale_fill_manual(values=c("#56B4E9", "#E69F00"))
# ColorBrewer2.org
# scale_colour_discrete = function(...) scale_colour_brewer(..., type="qual",palette="Dark2")
# scale_fill_discrete = function(...) scale_fill_brewer(..., type="qual",palette="Dark2")


.onLoad = function(lib, pkg) {
  options(guiToolkit = "RGtk2")
  library_call('gWidgetsRGtk2')
}

##' Load the package when necessary
##'
##' @param pkg a character of the package name.
##' @return NULL
##' @author Xiaoyue Cheng <\email{xycheng@@unomaha.edu}>
##' @noRd
##'
library_call = function(pkg) {
  library(pkg, character.only = TRUE)
}

##' Install the package when necessary
##'
##' @param pkg a character of the package name.
##' @return NULL
##' @author Xiaoyue Cheng <\email{xycheng@@unomaha.edu}>
##' @noRd
##'
library_gui = function(pkg) {
  if (require(pkg, character.only=TRUE)) return()
  if (gconfirm(paste('Install the missing package ', pkg, '?', sep = ''))) {
    install.packages(pkg)
    library_call(pkg)
  } else stop('The package ', pkg, ' is not available')
}

##' Compute the numeric summary of the missingness
##'
##' @param dat A data frame.
##' @return A list including (1) a data frame 'missingsummary' that provides
##' a table of missingness; (2) the total missing percentage; (3) the percent
##' of variables that contain missing values; (4) the ratio of observations
##' that have missings.
##' @author Xiaoyue Cheng <\email{xycheng@@unomaha.edu}>
##' @export
##' @examples
##' data(tao)
##' compute_missing_pct(tao)
##'
compute_missing_pct = function(dat){
    stopifnot(is.data.frame(dat))
    n = ncol(dat)
    totalmissingpct = mean(is.na(dat))
    varmissingpct = mean(sapply(dat,function(avec){any(is.na(avec))}))
    casemissingpct = 1-mean(complete.cases(dat))
    No_of_Case_missing = table(apply(dat, 1, function(avec){sum(is.na(avec))}))
    No_of_Case = rep(0,(n+1))
    No_of_Case[n+1-as.integer(names(No_of_Case_missing))]=No_of_Case_missing[names(No_of_Case_missing)]
    No_of_Case[n+1] = sum(complete.cases(dat))
    missingsummary = data.frame(No_of_miss_by_case=n:0,
                                No_of_Case=No_of_Case,
                                Percent=as.character(round(No_of_Case/nrow(dat)*100,1)))
    missingsummary = missingsummary[order(missingsummary$No_of_miss_by_case, decreasing=FALSE),]
    return(list(missingsummary=missingsummary,totalmissingpct=totalmissingpct,
                varmissingpct=varmissingpct,casemissingpct=casemissingpct))
}

##' Find the default methods given by \pkg{mice}
##'
##' @param vec a vector of the variable classes.
##' @param dat the data corresponding to vec.
##' @return A vector of the default imputation method generated by mice.
##' @author Xiaoyue Cheng <\email{xycheng@@unomaha.edu}>
##' @noRd
##'
mice_default = function(vec, dat){
    res = vec
    res[res %in% c("integer","numeric")] = "pmm"
    res[res == "logical"] = "logreg"
    for (i in which(vec %in% c('factor','character','ordered'))) {
        s = length(unique(na.omit(dat[,i])))
        if (s<3) {res[i] = "logreg"} else {
            res[i] = if (vec[i] == "ordered") {"polr"} else {"polyreg"}
        }
    }
    res[colSums(is.na(dat))==0] = ""
    return(res)
}

##' Print ggpair object in GTK+ for Windows platform
##'
##' See \code{print.ggpairs} from \pkg{GGally}.
##'
##' @param x ggpair object to be plotted
##' @param ... not used
##' @return NULL
##' @author Barret Schloerke <\email{schloerke@@gmail.com}>, Xiaoyue Cheng <\email{xycheng@@unomaha.edu}>
##' @importFrom GGally getPlot
##' @importFrom grid viewport unit grid.layout grid.newpage pushViewport grid.text gpar popViewport grid.rect
##' @noRd
##'
winprint = function (x, ...) {
  plotObj <- x
  if (identical(plotObj$axisLabels, "internal")) {
    v1 <- viewport(y = unit(0.5, "npc") - unit(0.5, "lines"),
                   width = unit(1, "npc") - unit(1, "lines"),
                   height = unit(1, "npc") - unit(2, "lines"))
  }
  else {
    v1 <- viewport(width = unit(1, "npc") - unit(3, "lines"),
                   height = unit(1, "npc") - unit(3, "lines"))
  }
  numCol <- length(plotObj$columns)
  v2 <- viewport(layout = grid.layout(numCol, numCol, widths = rep(1, numCol), heights = rep(1, numCol)))
  grid.newpage()
  if (plotObj$title != "") {
    pushViewport(viewport(height = unit(1, "npc") - unit(0.4, "lines")))
    grid.text(plotObj$title, x = 0.5, y = 1, just = c(0.5, 1), gp = gpar(fontsize = 15))
    popViewport()
  }
  if (!identical(plotObj$axisLabels, "internal")) {
    pushViewport(viewport(width = unit(1, "npc") - unit(2, "lines"),
                          height = unit(1, "npc") - unit(3, "lines")))
    pushViewport(viewport(layout = grid.layout(numCol, numCol, widths = rep(1, numCol),
                                               heights = rep(1, numCol))))
    for (i in 1:numCol) {
      grid.text(names(plotObj$data[, plotObj$columns])[i],
                0, 0.5, rot = 90, just = c("centre", "centre"),
                vp = viewport(layout.pos.row = as.numeric(i), layout.pos.col = 1))
    }
    popViewport()
    popViewport()
    pushViewport(viewport(width = unit(1, "npc") - unit(3, "lines"),
                          height = unit(1, "npc") - unit(2, "lines")))
    pushViewport(viewport(layout = grid.layout(numCol, numCol, widths = rep(1, numCol),
                                               heights = rep(1, numCol))))
    for (i in 1:numCol) {
      grid.text(names(plotObj$data[, plotObj$columns])[i],
                0.5, 0, just = c("centre", "centre"),
                vp = viewport(layout.pos.row = numCol, layout.pos.col = i))
    }
    popViewport()
    popViewport()
  }
  pushViewport(v1)
  pushViewport(v2)
  for (rowPos in 1:numCol) {
    for (columnPos in 1:numCol) {
      p <- getPlot(plotObj, rowPos, columnPos)
      p_cond <- if( !is.null(p$subType) && !is.null(p$type)){
        p$subType == "blank" && p$type == "blank"
      } else {FALSE}
      if (!p_cond) {
        pos <- columnPos + (rowPos - 1) * numCol
        type <- p$type
        subType <- p$subType
        if (plotObj$printInfo) {
          cat("Pos #", pos)
          if (!is.null(type))
            cat(": type = ", type)
          if (!is.null(subType))
            cat(": subType = ", subType)
          cat("\n")
        }
        noTicks <- c("internal", "none")
        removeTicks <- plotObj$axisLabels %in% noTicks
        if (!is.null(p$axisLabels)) {
          removeTicks <- p$axisLabels %in% noTicks
        }
        if (columnPos != 1 || removeTicks) {
          p <- p + theme(axis.text.y = element_blank(),
                         axis.title.y = element_blank())
        }
        if ((rowPos != numCol) || removeTicks) {
          p <- p + theme(#axis.text.x = element_blank(),
            axis.text.x = element_text(colour = "white"),
            axis.title.x = element_blank())
        }
        if (removeTicks) {
          p <- p + theme(strip.background = element_rect(fill = "white", colour = NA),
                         strip.text.x = element_blank(), strip.text.y = element_blank(),
                         axis.ticks = element_blank())
        }
        if (identical(p$type, "combo")) {
          p <- p + labs(x = NULL, y = NULL)
          if (plotObj$printInfo) {
            print(p$subType)
            print(p$horizontal)
          }
          if (p$horizontal) {
            if (p$subType %in% c("facethist")) {
              p <- p + theme(plot.margin = unit(c(0, -0.5, 0, 0), "lines"))
            }
            else {
              p <- p + theme(plot.margin = unit(c(0, -0.5, 0, -0.5), "lines"))
            }
            if (columnPos != numCol) {
              p <- p + theme(strip.background = element_blank(),
                             strip.text.x = element_blank(), strip.text.y = element_blank())
            }
          }
          else {
            if (p$subType %in% c("facethist")) {
              p <- p + theme(plot.margin = unit(c(-0.5, 0, 0, 0), "lines"))
            }
            else {
              p <- p + theme(plot.margin = unit(c(-0.5, 0, -0.5, 0), "lines"))
            }
            if (rowPos != 1) {
              p <- p + theme(strip.background = element_blank(),
                             strip.text.x = element_blank(), strip.text.y = element_blank())
            }
          }
        }
        else if (identical(p$subType, "facetbar")) {
          p <- p + labs(x = NULL, y = NULL) + theme(plot.margin = unit(c(0, -0.5, 0, 0), "lines"))
          if (rowPos != 1) {
            p <- p + theme(strip.background = element_blank(),
                           strip.text.x = element_blank(), strip.text.y = element_blank())
          }
        }
        else if (identical(p$type, "continuous") && !identical(p$subType, "cor")) {
          p <- p + labs(x = NULL, y = NULL) + theme(plot.margin = unit(rep(0, 4), "lines"))
        }
        else if (identical(p$type, "diag") && is.numeric(p$data[, as.character(p$mapping$x)])) {
          p <- p + labs(x = NULL, y = NULL) + theme(plot.margin = unit(rep(0, 4), "lines"))
        }
        else {
          p <- p + labs(x = NULL, y = NULL) + theme(plot.margin = unit(rep(0, 4), "lines"))
        }
        showLegend = FALSE
        if (!is.null(plotObj$legends))
          showLegend <- identical(plotObj$legends, TRUE)
        if (showLegend == FALSE) {
          if (!is.null(p$ggally$legend) && !is.na(p$ggally$legend)) {
            showLegend <- identical(p$ggally$legend, TRUE)
          }
        }
        if (showLegend == FALSE) {
          p <- p + theme(legend.position = "none")
        }
        grid.rect(gp = gpar(fill = "white", lty = "blank"),
                  vp = viewport(layout.pos.row = rowPos, layout.pos.col = columnPos))
        if (identical(plotObj$verbose, TRUE)) {
          print(p, vp = viewport(layout.pos.row = rowPos, layout.pos.col = columnPos))
        }
        else {
          suppressMessages(suppressWarnings(print(p, vp = viewport(layout.pos.row = rowPos, layout.pos.col = columnPos))))
        }
      }
    }
  }
  popViewport()
  popViewport()
}