Article Outline
#（99%自分用メモ）RcmdrPlugin.KMggplot2にメニュー追加
（注意）OSはLinux。/home/(ユーザー名)/R/x86_64-pc-linux-gnu-library/(Rバージョン)にインストール。
(windowsならRtoolsが必要。)
- Rcmdr : 2.7.2
- RcmdrPlugin.KMggplot2 : 0.2.6
- ggplot2 : 3.3.5
- ggmosaic : 0.3.3
RcmdrPlugin.KMggplot2 : 0.2.6 の（多分）バグ
plot-aaa.r
471: (誤) facet <- "facet_wrap( ~ s) + \n "
(正) facet <- "facet_grid(s ~ .) + \n "
以下は追加、変更する箇所
menus.txt
(追加)
item kmg2Menu command "Bar chart" windowBar "nonFactorsP()" ""
item kmg2Menu command "Mosaic Plot" windowMosaic "factorsP()" ""
DESCRIPTION
Depends: に ggmosaic (>= 0.3.3) を追加
Collate: に 'plot-gbar.r' 'plot-gmosaic.r' 'ChangeColor.R' を追加
NAMESPACE
(追加)
export(gmosaic)
export(windowMosaic)
export(gbar)
export(windowBar)
export(changecolor)
import(ggmosaic)
追加する関数(.r ファイルは３つ)
ChangeColor.R
棒グラフやヒストグラムを単色で塗りつぶす色を変更したい場合。コマンドとして使う。メニューにはない。
changecolor()とかchangecolor("brown3","royalblue3",1)のように使う。
（注意）colourとsizeは複数の色で塗る際にも影響あり。
changecolor <- function(fill= "gray55",colour="black",size=0.25) {
# default : fill="grey35" , colour="NA" ,size=0.5
barcolor = paste0("update_geom_defaults('bar',list(fill = '",fill,"',colour='",colour,"',size=",size,"))")
colcolor = paste0("update_geom_defaults('col',list(fill = '",fill,"',colour='",colour,"',size=",size,"))")
eval(parse(text = barcolor))
eval(parse(text = colcolor))
}これを
こうしたり、ああしたり、
plot-gbar.r
plot-gbox.rを参考に作成。box一個なくして（その箇所削って）、if文削って、geom_boxplotをgeom_colに変えた程度。
gbar <- setRefClass(
Class = "gbar",
fields = c("vbbox1", "vbbox2", "lbbox1", "rbbox1","cbbox1", "tbbox1"),
contains = c("plot_base"),
methods = list(
setFront = function() {
vbbox1 <<- variableboxes$new()
vbbox1$front(
top = top,
types = list(Factors(), nonFactors(), Factors()),
titles = list(
gettextKmg2("X variable"),
gettextKmg2("Y variable (pick one)"),
gettextKmg2("Stratum variable")
),
initialSelection = list(FALSE, 0, FALSE)
)
#
vbbox2 <<- variableboxes$new()
vbbox2$front(
top = top,
types = list(Factors(), Factors()),
titles = list(
gettextKmg2("Facet variable in rows"),
gettextKmg2("Facet variable in cols")
)
)
lbbox1 <<- textfields$new()
lbbox1$front(
top = top,
initValues = list("<auto>", "<auto>", "<auto>", ""),
titles = list(
gettextKmg2("Horizontal axis label"),
gettextKmg2("Vertical axis label"),
gettextKmg2("Legend label"),
gettextKmg2("Title")
)
)
rbbox1 <<- radioboxes$new()
rbbox1$front(
top = alternateFrame,
labels = list(
gettextKmg2("Bar chart(stack,Sum)"),
gettextKmg2("Bar chart(dodge)"),
gettextKmg2("Bar chart(fill)") ,
gettextKmg2("Bar chart(mean)") ,
gettextKmg2("Bar chart(mean+95% C.I.)")
),
title = gettextKmg2("Plot type")
)
cbbox1 <<- checkboxes$new()
cbbox1$front(
top = alternateFrame,
initValues = list("0"),
labels = list(
gettextKmg2("Flipped coordinates")
),
title = gettextKmg2("Options")
)
tbbox1 <<- toolbox$new()
tbbox1$front(top)
},
setBack = function() {
vbbox1$back()
vbbox2$back()
lbbox1$back()
tkgrid(
rbbox1$frame,
labelRcmdr(alternateFrame, text=" "),
cbbox1$frame,
labelRcmdr(alternateFrame, text=" "),
stick="nw")
tkgrid(alternateFrame, stick="nw")
tkgrid(labelRcmdr(alternateFrame, text=" "), stick="nw")
tbbox1$back()
},
getWindowTitle = function() {
gettextKmg2("Bar chart")
},
getHelp = function() {
"geom_boxplot"
},
getParms = function() {
x <- getSelection(vbbox1$variable[[1]])
y <- getSelection(vbbox1$variable[[2]])
z <- getSelection(vbbox1$variable[[3]])
s <- getSelection(vbbox2$variable[[1]])
t <- getSelection(vbbox2$variable[[2]])
x <- checkVariable(x)
y <- checkVariable(y)
z <- checkVariable(z)
s <- checkVariable(s)
t <- checkVariable(t)
xlab <- tclvalue(lbbox1$fields[[1]]$value)
xauto <- x
ylab <- tclvalue(lbbox1$fields[[2]]$value)
yauto <- y
zlab <- tclvalue(lbbox1$fields[[3]]$value)
zauto <- z
main <- tclvalue(lbbox1$fields[[4]]$value)
if (length(x) == 0 && length(z) != 0) {
xlab <- zlab
xauto <- zauto
}
size <- tclvalue(tbbox1$size$value)
family <- getSelection(tbbox1$family)
colour <- getSelection(tbbox1$colour)
save <- tclvalue(tbbox1$goption$value[[1]])
theme <- checkTheme(getSelection(tbbox1$theme))
options(
kmg2FontSize = tclvalue(tbbox1$size$value),
kmg2FontFamily = seq_along(tbbox1$family$varlist)[tbbox1$family$varlist == getSelection(tbbox1$family)] - 1,
kmg2ColourSet = seq_along(tbbox1$colour$varlist)[tbbox1$colour$varlist == getSelection(tbbox1$colour)] - 1,
kmg2SaveGraph = tclvalue(tbbox1$goption$value[[1]]),
kmg2Theme = seq_along(tbbox1$theme$varlist)[tbbox1$theme$varlist == getSelection(tbbox1$theme)] - 1
)
plotType <- tclvalue(rbbox1$value)
flipedCoordinates <- tclvalue(cbbox1$value[[1]])
list(
x = x, y = y, z = z, s = s, t = t,
xlab = xlab, xauto = xauto, ylab = ylab, yauto = yauto, zlab = zlab, main = main,
size = size, family = family, colour = colour, save = save, theme = theme,
plotType = plotType, flipedCoordinates = flipedCoordinates
)
},
checkError = function(parms) {
if (length(parms$y) == 0) {
errorCondition(
recall = windowBar,
message = gettextKmg2("Y variable is not selected")
)
errorCode <- TRUE
} else {
errorCode <- FALSE
}
errorCode
},
getGgplot = function(parms) {
ztype <- "fill"
if (length(parms$x) == 0 && length(parms$z) == 0) {
ggplot <- "ggplot(data = .df, aes(x = factor(1), y = y)) + \n " # 1
} else if (length(parms$x) == 0) {
ggplot <- paste0("ggplot(data = .df, aes(x = z, y = y, ", ztype, " = z)) + \n ")
} else if (length(parms$z) == 0) {
ggplot <- "ggplot(data = .df, aes(x = factor(x), y = y)) + \n "
} else {
ggplot <- paste0("ggplot(data = .df, aes(x = factor(x), y = y, ", ztype, " = z)) + \n ")
}
ggplot
},
getGeom = function(parms) {
if (length(parms$x) != 0 && length(parms$z) != 0) {
dodge1 <- "position = position_dodge(width = 0.9), "
dodge2 <- "position = position_dodge(width = 0.9)"
} else {
dodge1 <- dodge2 <- ""
}
if (parms$plotType == "1") {
geom <- paste0(
"geom_col() + \n ",
"scale_y_continuous(expand = c(0.01,0),labels = scales::comma) + \n "
)
} else if (parms$plotType == "2") {
geom <- paste0(
"geom_col(position='dodge') + \n ",
"scale_y_continuous(expand = c(0.01,0), limits = c(0,max(.df$y,na.rm=1)*1.02),labels = scales::comma) + \n "
)
} else if (parms$plotType == "3") {
geom <- paste0(
"geom_col(position='fill') + \n ",
"scale_y_continuous(expand = c(0.01,0),labels = scales::percent) + \n "
)
}else if (parms$plotType == "4") {
geom <- paste(
"stat_summary(fun = \"mean\", geom = \"bar\", ", dodge2, ") + \n " ,
"scale_y_continuous(expand = c(0.01,0),labels = scales::comma) + \n "
)
}else if (parms$plotType == "5") {
geom <- paste(
"stat_summary(fun = \"mean\", geom = \"bar\", ", dodge2, ") + \n ",
"stat_summary(fun.data = \"mean_cl_normal\", geom = \"errorbar\", ",
dodge1, "width = 0.1, fun.args = list(conf.int = 0.95)) + \n ",
"scale_y_continuous(expand = c(0.01,0),labels = scales::comma) + \n "
)
}
geom
},
getScale = function(parms) {
if (length(parms$x) == 0 && length(parms$z) == 0) {
scale <- "scale_x_discrete(breaks = NULL) + \n "
} else if (length(parms$z) != 0) {
if (parms$colour == "Default") {
scale <- ""
} else if (parms$colour == "Hue") {
scale <- paste0("scale_fill_hue() + \n ")
} else if (parms$colour == "Grey") {
scale <- paste0("scale_fill_grey() + \n ")
} else {
scale <- paste0("scale_fill_brewer(palette = \"", parms$colour, "\") + \n ")
}
} else {
scale <- ""
}
scale
},
getCoord = function(parms) {
if (parms$flipedCoordinates == "1") {
coord <- "coord_flip() + \n "
} else {
coord <- ""
}
coord
},
getZlab = function(parms) {
if (length(parms$z) == 0) {
zlab <- ""
} else if (parms$zlab == "<auto>") {
zlab <- paste0("labs(fill = \"", parms$z, "\") + \n ")
}
zlab
},
getOpts = function(parms) {
opts <- list()
if (length(parms$s) != 0 || length(parms$t) != 0) {
opts <- c(opts, "panel.spacing = unit(0.3, \"lines\")")
}
if (length(parms$x) == 0 && length(parms$z) == 0) {
if (parms$flipedCoordinates == "0") {
opts <- c(opts, "axis.title.x = element_blank()", "axis.text.x = element_blank()")
} else {
opts <- c(opts, "axis.title.y = element_blank()", "axis.text.y = element_blank()")
}
}
if (length(opts) != 0) {
opts <- do.call(paste, c(opts, list(sep = ", ")))
opts <- paste0(" + \n theme(", opts, ")")
} else {
opts <- ""
}
opts
}
)
)
windowBar <- function() {
Bar <- RcmdrPlugin.KMggplot2::gbar$new()
Bar$plotWindow()
}
plot-gmosaic.r
ggmosaicパッケージはもっと多機能だが、モザイクプロットの表示に絞った。
関数に入れる変数の順序と表示位置（x,y軸方向）にくせがあるので関数に渡す際の順番を変えたりした。
モザイクプロットは、vcd パッケージのmosaic関数が一押しだけど、表示はカラー色を使えるので抜群にきれい。
(注意)mosaicという命令はvcdとggmosaicどちらにもあるので衝突をおこす。
gmosaic <- setRefClass(
Class = "gmosaic",
fields = c("vbbox1", "rbbox1","vbbox2", "lbbox1","tbbox1"),
contains = c("plot_base"),
methods = list(
setFront = function() {
vbbox1 <<- variableboxes$new()
vbbox1$front(
top = top,
types = list(Factors(),Factors(),Factors()),
titles = list(
gettextKmg2("variable (pick one)") ,
gettextKmg2("variable (pick 0 or 1)") ,
gettextKmg2("Stratum variable")
),
initialSelection = list( 0,FALSE,FALSE)
)
lbbox1 <<- textfields$new()
lbbox1$front(
top = top,
initValues = list("<auto>", "<auto>","<auto>", ""),
titles = list(
gettextKmg2("Horizontal axis label"),
gettextKmg2("Vertical axis label"),
gettextKmg2("Legend label"),
gettextKmg2("Title")
),
)
vbbox2 <<- variableboxes$new()
vbbox2$front(
top = top,
types = list(Factors()),
titles = list(
gettextKmg2("Facet variable in cols")
)
)
rbbox1 <<- radioboxes$new()
rbbox1$front(
top = alternateFrame,
labels = list(
gettextKmg2("angle=0"),
gettextKmg2("angle=45"),
gettextKmg2("angle=90")
),
title = gettextKmg2("axis.text.x")
)
tbbox1 <<- toolbox$new()
tbbox1$front(top)
},
setBack = function() {
vbbox1$back()
vbbox2$back()
lbbox1$back()
tkgrid(
rbbox1$frame,
labelRcmdr(alternateFrame, text=" "),
stick="nw")
tkgrid(alternateFrame, stick="nw")
tkgrid(labelRcmdr(alternateFrame, text=" "), stick="nw")
tbbox1$back()
},
getWindowTitle = function() {
gettextKmg2("Mosaicplot")
},
getHelp = function() {
"geom_mosaic"
},
getParms = function() {
x <- getSelection(vbbox1$variable[[1]])
y <- getSelection(vbbox1$variable[[2]])
z <- getSelection(vbbox1$variable[[3]])
x <- checkVariable(x)
s <- NULL
t <- NULL
tt <- getSelection(vbbox2$variable[[1]])
tt <- checkVariable(tt)
xlab <- tclvalue(lbbox1$fields[[1]]$value)
xauto <- x
ylab <- tclvalue(lbbox1$fields[[2]]$value)
yauto <- y
zlab <- tclvalue(lbbox1$fields[[3]]$value)
zauto <- z
#######################################################################
if (length(y) != 0 && length(z) != 0) {
xauto<- paste(z,":",x)
yauto<- y
}
if (length(y) == 0 && length(z) != 0) {
yauto<- z
xauto<- x
}
#######################################################################
main <- tclvalue(lbbox1$fields[[4]]$value)
size <- tclvalue(tbbox1$size$value)
family <- getSelection(tbbox1$family)
colour <- getSelection(tbbox1$colour)
save <- tclvalue(tbbox1$goption$value[[1]])
theme <- checkTheme(getSelection(tbbox1$theme))
options(
kmg2FontSize = tclvalue(tbbox1$size$value),
kmg2FontFamily = seq_along(tbbox1$family$varlist)[tbbox1$family$varlist == getSelection(tbbox1$family)] - 1,
kmg2ColourSet = seq_along(tbbox1$colour$varlist)[tbbox1$colour$varlist == getSelection(tbbox1$colour)] - 1,
kmg2SaveGraph = tclvalue(tbbox1$goption$value[[1]]),
kmg2Theme = seq_along(tbbox1$theme$varlist)[tbbox1$theme$varlist == getSelection(tbbox1$theme)] - 1
)
xangle <- tclvalue(rbbox1$value)
list(
x = x, y = y, z = z, s = s , t = t , tt = tt ,
xlab = xlab, xauto = xauto, ylab = ylab, yauto = yauto, zlab = zlab,zauto=zauto, main = main,
size = size, family = family, colour = colour, save = save, theme = theme,
xangle = xangle
)
},
checkError = function(parms) {
if (length(parms$x) == 0) {
errorCondition(
recall = windowMosaic,
message = gettextKmg2("Variable is not selected")
)
errorCode <- TRUE
} else {
errorCode <- FALSE
}
errorCode
},
setDataframe = function(parms) {
var <- list()
if (length(parms$x) != 0) {
var <- c(var, paste0(parms$x," = ", ActiveDataSet(), "$", parms$x))
}
if (length(parms$y) != 0) {
var <- c(var, paste0(parms$y," = ", ActiveDataSet(), "$", parms$y))
}
if (length(parms$z) != 0) {
var <- c(var, paste0(parms$z," = ", ActiveDataSet(), "$", parms$z))
}
if (length(parms$tt) != 0) {
var <- c(var, paste0(parms$tt," = ", ActiveDataSet(), "$", parms$tt))
}
# if (length(parms$tt) != 0) {
# var <- c(var, paste0("tt = ", ActiveDataSet(), "$", parms$tt))
# }
command <- do.call(paste, c(var, list(sep = ", ")))
command <- paste0(".df <- na.omit(data.frame(", command, "))")
commandDoIt("require(\"ggmosaic\")", log = TRUE)
# doItAndPrint("require(\"ggmosaic\")")
commandDoIt(command)
registRmlist(.df)
},
getGgplot = function(parms) {
ggplot<- "ggplot(data = .df) + \n "
ggplot
},
getGeom = function(parms) {
if (length(parms$y) == 0 && length(parms$z) == 0) {
geom <- paste0("geom_mosaic(aes(x=product(",parms$x,")) ) + \n ")
} else if (length(parms$z) == 0) {
geom <- paste0("geom_mosaic(aes(x=product(",parms$y,",",parms$x,"))) + \n ")
} else if (length(parms$y) == 0) {
geom <- paste0("geom_mosaic(aes(x=product(",parms$x,"),fill=",parms$z,")) + \n ")
} else {
geom <- paste0("geom_mosaic(aes(x=product(",parms$y,",",parms$x,"),fill=",parms$z,")) + \n ")
}
if (length(parms$tt) != 0 ) {
geom <- paste0(geom , "facet_wrap( ~ ",parms$tt," , ncol = 2, scale = \"free\") + \n ")
}else{
geom<- geom
}
geom
},
getScale = function(parms) {
if (length(parms$x) == 0 && length(parms$z) == 0) {
scale <- "scale_x_discrete(breaks = NULL) + \n "
} else if (length(parms$z) != 0) {
if (parms$colour == "Default") {
scale <- ""
} else if (parms$colour == "Hue") {
scale <- paste0("scale_fill_hue() + \n ")
} else if (parms$colour == "Grey") {
scale <- paste0("scale_fill_grey() + \n ")
} else {
scale <- paste0("scale_fill_brewer(palette = \"", parms$colour, "\") + \n ")
}
} else {
scale <- ""
}
scale
},
getOpts = function(parms) {
opts <- list()
if (parms$xangle == 1) {
opts <- c("axis.text.x = element_text(angle = 0)")
} else if (parms$xangle == "2") {
opts <- c("axis.text.x = element_text(angle = 45, hjust =0.5, vjust = 1.1)")
} else if (parms$xangle == "3") {
opts <- c("axis.text.x = element_text(angle = 90, vjust = 0.5, hjust = 1)")
} else {
opts <- c("axis.text.x = element_text(angle = 0)")
}
opts <- c(opts, "axis.ticks=element_blank(),panel.border = element_blank(), axis.text=element_text(colour = \"black\"),panel.grid.major = element_blank(), panel.grid.minor = element_blank()")
if (length(opts) != 0) {
opts <- do.call(paste, c(opts, list(sep = ", ")))
opts <- paste0(" + \n theme(", opts, ")")
} else {
opts <- ""
}
opts
}
)
)
windowMosaic <- function() {
Mosaic <- RcmdrPlugin.KMggplot2::gmosaic$new()
Mosaic$plotWindow()
}
（おまけ:もとからある関数に付け加え）plot-gbox.r
欠損値があるデータに対応するために、plot-gbox.r に cbbox2 を追加して、scale_x_discrete(na.translate = FALSE) を書き加えることができるようにした。
gbox <- setRefClass(
Class = "gbox",
# fields = c("vbbox1", "vbbox2", "lbbox1", "rbbox1", "rbbox2", "cbbox1", "tbbox1"),
fields = c("vbbox1", "vbbox2", "lbbox1", "rbbox1", "rbbox2", "cbbox1", "cbbox2", "tbbox1"),
contains = c("plot_base"),
methods = list(
setFront = function() {
vbbox1 <<- variableboxes$new()
vbbox1$front(
top = top,
types = list(Variables(), nonFactors(), Factors()),
titles = list(
gettextKmg2("X variable"),
gettextKmg2("Y variable (pick one)"),
gettextKmg2("Stratum variable")
),
initialSelection = list(FALSE, 0, FALSE)
)
vbbox2 <<- variableboxes$new()
vbbox2$front(
top = top,
types = list(Factors(), Factors()),
titles = list(
gettextKmg2("Facet variable in rows"),
gettextKmg2("Facet variable in cols")
)
)
lbbox1 <<- textfields$new()
lbbox1$front(
top = top,
initValues = list("<auto>", "<auto>", "<auto>", ""),
titles = list(
gettextKmg2("Horizontal axis label"),
gettextKmg2("Vertical axis label"),
gettextKmg2("Legend label"),
gettextKmg2("Title")
)
)
rbbox1 <<- radioboxes$new()
rbbox1$front(
top = alternateFrame,
labels = list(
gettextKmg2("Box plot"),
gettextKmg2("Notched box plot"),
gettextKmg2("Violin plot"),
gettextKmg2("95% C.I. (t distribution)"),
gettextKmg2("95% C.I. (bootstrap)")
),
title = gettextKmg2("Plot type")
)
cbbox1 <<- checkboxes$new()
cbbox1$front(
top = alternateFrame,
initValues = list("0"),
labels = list(
gettextKmg2("Flipped coordinates")
),
title = gettextKmg2("Options")
)
##############################################################
cbbox2 <<- checkboxes$new()
cbbox2$front(
top = alternateFrame,
initValues = list("0"),
labels = list(
gettextKmg2("FALSE")
),
title = gettextKmg2("na.translate")
)
##############################################################
rbbox2 <<- radioboxes$new()
rbbox2$front(
top = alternateFrame,
labels = list(
gettextKmg2("None"),
gettextKmg2("Jitter"),
gettextKmg2("Beeswarm")
),
title = gettextKmg2("Add data point")
)
tbbox1 <<- toolbox$new()
tbbox1$front(top)
},
setBack = function() {
vbbox1$back()
vbbox2$back()
lbbox1$back()
tkgrid(
rbbox1$frame,
labelRcmdr(alternateFrame, text=" "),
cbbox1$frame,
#
cbbox2$frame,
#
labelRcmdr(alternateFrame, text=" "),
rbbox2$frame,
stick="nw")
tkgrid(alternateFrame, stick="nw")
tkgrid(labelRcmdr(alternateFrame, text=" "), stick="nw")
tbbox1$back()
},
getWindowTitle = function() {
gettextKmg2("Box plot / Violin plot / Confidence interval")
},
getHelp = function() {
"geom_boxplot"
},
getParms = function() {
x <- getSelection(vbbox1$variable[[1]])
y <- getSelection(vbbox1$variable[[2]])
z <- getSelection(vbbox1$variable[[3]])
s <- getSelection(vbbox2$variable[[1]])
t <- getSelection(vbbox2$variable[[2]])
x <- checkVariable(x)
y <- checkVariable(y)
z <- checkVariable(z)
s <- checkVariable(s)
t <- checkVariable(t)
xlab <- tclvalue(lbbox1$fields[[1]]$value)
xauto <- x
ylab <- tclvalue(lbbox1$fields[[2]]$value)
yauto <- y
zlab <- tclvalue(lbbox1$fields[[3]]$value)
zauto <- z
main <- tclvalue(lbbox1$fields[[4]]$value)
if (length(x) == 0 && length(z) != 0) {
xlab <- zlab
xauto <- zauto
}
size <- tclvalue(tbbox1$size$value)
family <- getSelection(tbbox1$family)
colour <- getSelection(tbbox1$colour)
save <- tclvalue(tbbox1$goption$value[[1]])
theme <- checkTheme(getSelection(tbbox1$theme))
options(
kmg2FontSize = tclvalue(tbbox1$size$value),
kmg2FontFamily = seq_along(tbbox1$family$varlist)[tbbox1$family$varlist == getSelection(tbbox1$family)] - 1,
kmg2ColourSet = seq_along(tbbox1$colour$varlist)[tbbox1$colour$varlist == getSelection(tbbox1$colour)] - 1,
kmg2SaveGraph = tclvalue(tbbox1$goption$value[[1]]),
kmg2Theme = seq_along(tbbox1$theme$varlist)[tbbox1$theme$varlist == getSelection(tbbox1$theme)] - 1
)
plotType <- tclvalue(rbbox1$value)
flipedCoordinates <- tclvalue(cbbox1$value[[1]])
#
naomit <- tclvalue(cbbox2$value[[1]])
#
dataPoint <- tclvalue(rbbox2$value)
list(
x = x, y = y, z = z, s = s, t = t,
xlab = xlab, xauto = xauto, ylab = ylab, yauto = yauto, zlab = zlab, main = main,
size = size, family = family, colour = colour, save = save, theme = theme,
plotType = plotType, flipedCoordinates = flipedCoordinates,naomit=naomit ,dataPoint = dataPoint
)
},
checkError = function(parms) {
if (length(parms$y) == 0) {
errorCondition(
recall = windowBox,
message = gettextKmg2("Y variable is not selected")
)
errorCode <- TRUE
} else {
errorCode <- FALSE
}
errorCode
},
getGgplot = function(parms) {
if (parms$plotType == "1" || parms$plotType == "2" || parms$plotType == "3") {
ztype <- "fill"
} else {
ztype <- "colour"
}
if (length(parms$x) == 0 && length(parms$z) == 0) {
ggplot <- "ggplot(data = .df, aes(x = factor(1), y = y)) + \n "
} else if (length(parms$x) == 0) {
ggplot <- paste0("ggplot(data = .df, aes(x = z, y = y, ", ztype, " = z)) + \n ")
} else if (length(parms$z) == 0) {
ggplot <- "ggplot(data = .df, aes(x = factor(x), y = y)) + \n "
} else {
if (parms$plotType == "1" || parms$plotType == "2" || parms$plotType == "3") {
ggplot <- paste0("ggplot(data = .df, aes(x = factor(x), y = y, ", ztype, " = z)) + \n ")
} else if (parms$dataPoint != "1") {
ggplot <- paste0("ggplot(data = .df, aes(x = factor(x), y = y, ", ztype, " = z, fill = z)) + \n ")
} else {
ggplot <- paste0("ggplot(data = .df, aes(x = factor(x), y = y, ", ztype, " = z)) + \n ")
}
}
ggplot
},
getGeom = function(parms) {
if (length(parms$x) != 0 && length(parms$z) != 0) {
dodge1 <- "position = position_dodge(width = 0.9), "
dodge2 <- "position = position_dodge(width = 0.9)"
} else {
dodge1 <- dodge2 <- ""
}
if (parms$plotType == "1") {
if (parms$dataPoint == "1") {
geom <- paste0(
"stat_boxplot(geom = \"errorbar\", ", dodge1, "width = 0.5) + \n ",
"geom_boxplot(", dodge2, ") + \n "
)
} else {
geom <- paste0(
"stat_boxplot(geom = \"errorbar\", ", dodge1, "width = 0.5) + \n ",
"geom_boxplot(", dodge1, "outlier.colour = \"transparent\") + \n "
)
}
} else if (parms$plotType == "2") {
if (parms$dataPoint == "1") {
geom <- paste0(
"stat_boxplot(geom = \"errorbar\", ", dodge1, "width = 0.5) + \n ",
"geom_boxplot(", dodge1, "notch = TRUE) + \n "
)
} else {
geom <- paste0(
"stat_boxplot(geom = \"errorbar\", ", dodge1, "width = 0.5) + \n ",
"geom_boxplot(", dodge1, "outlier.colour = \"transparent\", notch = TRUE) + \n "
)
}
} else if (parms$plotType == "3") {
geom <- paste0(
"geom_violin(", dodge2, ") + \n ",
"stat_summary(fun = \"median\", geom = \"point\", ", dodge1, "pch = 10, size = 4) + \n "
)
} else if (parms$plotType == "4") {
geom <- paste0(
"stat_summary(fun = \"mean\", geom = \"point\", ", dodge2, ") + \n ",
"stat_summary(fun.data = \"mean_cl_normal\", geom = \"errorbar\", ",
dodge1, "width = 0.1, fun.args = list(conf.int = 0.95)) + \n "
)
} else if (parms$plotType == "5") {
geom <- paste(
"stat_summary(fun = \"mean\", geom = \"point\", ", dodge2, ") + \n ",
"stat_summary(fun.data = \"mean_cl_boot\", geom = \"errorbar\", ",
dodge1, "width = 0.1, fun.args = list(conf.int = 0.95)) + \n "
)
}
if (parms$dataPoint == "1") {
} else if (parms$dataPoint == "2") {
if (length(parms$x) != 0 && length(parms$z) != 0) {
geom <- paste0(
geom,
"geom_jitter(colour = \"black\", position = position_jitterdodge(jitter.width = 0.25, jitter.height = 0, dodge.width = 0.9)) + \n "
)
} else {
geom <- paste0(
geom,
"geom_jitter(colour = \"black\", width = 0.1, height = 0) + \n "
)
}
} else if (parms$dataPoint == "3") {
geom <- paste0(
geom,
"geom_dotplot(binaxis = \"y\", stackdir = \"center\", position = position_dodge(width = 0.9)) + \n "
)
}
if (parms$naomit == "1") {
geom <- paste0(
geom ,
"scale_x_discrete(na.translate = FALSE) + \n "
)
} else {
}
geom
},
getScale = function(parms) {
if (length(parms$x) == 0 && length(parms$z) == 0) {
scale <- "scale_x_discrete(breaks = NULL) + \n "
} else if (length(parms$z) != 0) {
if (parms$plotType == "1" || parms$plotType == "2" || parms$plotType == "3") {
if (parms$colour == "Default") {
scale <- ""
} else if (parms$colour == "Hue") {
scale <- paste0("scale_fill_hue() + \n ")
} else if (parms$colour == "Grey") {
scale <- paste0("scale_fill_grey() + \n ")
} else {
scale <- paste0("scale_fill_brewer(palette = \"", parms$colour, "\") + \n ")
}
} else {
if (parms$colour == "Default") {
scale <- ""
} else if (parms$colour == "Hue") {
scale <- paste0("scale_colour_hue() + \n ")
} else if (parms$colour == "Grey") {
scale <- paste0("scale_colour_grey() + \n ")
} else {
scale <- paste0("scale_colour_brewer(palette = \"", parms$colour, "\") + \n ")
}
}
} else {
scale <- ""
}
scale
},
getCoord = function(parms) {
if (parms$flipedCoordinates == "1") {
coord <- "coord_flip() + \n "
} else {
coord <- ""
}
coord
},
getZlab = function(parms) {
if (length(parms$z) == 0) {
zlab <- ""
} else if (parms$zlab == "<auto>") {
if (parms$plotType == "1" || parms$plotType == "2" || parms$plotType == "3") {
zlab <- paste0("labs(fill = \"", parms$z, "\") + \n ")
} else if (parms$dataPoint != "1") {
zlab <- paste0("labs(fill = \"", parms$z, "\", colour = \"", parms$z, "\") + \n ")
} else {
zlab <- paste0("labs(colour = \"", parms$z, "\") + \n ")
}
} else {
if (parms$plotType == "1" || parms$plotType == "2" || parms$plotType == "3") {
zlab <- paste0("labs(fill = \"", parms$zlab, "\") + \n ")
} else if (parms$dataPoint != "1") {
zlab <- paste0("labs(fill = \"", parms$zlab, "\", colour = \"", parms$zlab, "\") + \n ")
} else {
zlab <- paste0("labs(colour = \"", parms$zlab, "\") + \n ")
}
}
zlab
},
getOpts = function(parms) {
opts <- list()
if (length(parms$s) != 0 || length(parms$t) != 0) {
opts <- c(opts, "panel.spacing = unit(0.3, \"lines\")")
}
if (length(parms$x) == 0 && length(parms$z) == 0) {
if (parms$flipedCoordinates == "0") {
opts <- c(opts, "axis.title.x = element_blank()", "axis.text.x = element_blank()")
} else {
opts <- c(opts, "axis.title.y = element_blank()", "axis.text.y = element_blank()")
}
}
if (length(opts) != 0) {
opts <- do.call(paste, c(opts, list(sep = ", ")))
opts <- paste0(" + \n theme(", opts, ")")
} else {
opts <- ""
}
opts
}
)
)
windowBox <- function() {
Box <- RcmdrPlugin.KMggplot2::gbox$new()
Box$plotWindow()
}
