Nothing
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()
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.