Nothing
R/plotVar.R
In mixOmics: Omics Data Integration Project
Defines functions
plotVar
Documented in
plotVar
#############################################################################################################
# Authors:
# Ignacio Gonzalez, Genopole Toulouse Midi-Pyrenees, France
# Benoit Gautier, The University of Queensland, The University of Queensland Diamantina Institute, Translational Research Institute, Brisbane, QLD
# Francois Bartolo, Institut National des Sciences Appliquees et Institut de Mathematiques, Universite de Toulouse et CNRS (UMR 5219), France
# Florian Rohart, The University of Queensland Diamantina Institute, Translational Research Institute, Brisbane, QLD
# Kim-Anh Le Cao, The University of Queensland Diamantina Institute, Translational Research Institute, Brisbane, QLD
#
# created: 2009
# last modified: 24-08-2016
#
# Copyright (C) 2009
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# last modified: 01-03-2016
#----------------------------------------------------------------------------------------------------------#
#-- Includes plotVar for PLS, sPLS, PLS-DA, SPLS-DA, rCC, PCA, sPCA, IPCA, sIPCA, rGCCA, sGCCA, sGCCDA --#
#----------------------------------------------------------------------------------------------------------#
plotVar <-
function(object,
comp = NULL,
comp.select = comp,
plot = TRUE,
var.names = NULL,
blocks = NULL, # to choose which block data to plot, when using GCCA module
X.label = NULL,
Y.label = NULL,
Z.label = NULL,
abline = TRUE,
col,
cex,
pch,
font,
cutoff = 0,
rad.in = 0.5,
title = "Correlation Circle Plots",
legend = FALSE,
style="ggplot2", # can choose between graphics,3d, lattice or ggplot2,
overlap = TRUE,
axes.box = "all",
label.axes.box = "both" )
{
class.object = class(object)
object.pls=c("pls","spls","mlspls","mlsplsda","rcc")
object.pca=c("ipca","sipca","pca","spca")
object.blocks=c("sgcca","rgcca")
#-- check that the user did not enter extra arguments
arg.call = match.call()
user.arg = names(arg.call)[-1]
err = tryCatch(mget(names(formals()), sys.frame(sys.nframe())),
error = function(e) e)
if ("simpleError" %in% class(err))
stop(err[[1]], ".", call. = FALSE)
#-- style
if (!style %in% c("ggplot2", "lattice", "graphics","3d"))
stop("'style' must be one of 'ggplot2', '3d' , lattice' or 'graphics'.", call. = FALSE)
#-- plot
if (length(plot) > 1)
stop("'plot' must be single logical value.", call. = FALSE)
else if (!is.logical(plot))
stop("'plot' must be logical.", call. = FALSE)
if(!plot)
{
style="N"}
#-- axes.box
if(style=="3d")
{
choices = c("axes", "box", "bbox", "all")
axes.box = choices[pmatch(axes.box, choices)]
if (is.na(axes.box))
stop("'axes.box' should be a subset of {'axes', 'box', 'bbox', 'all'}.",
call. = FALSE)
#-- label.axes.box
choices = c("axes", "box", "both")
label.axes.box = choices[pmatch(label.axes.box, choices)]
if (is.na(label.axes.box))
stop("'label.axes.box' should be one of 'axes', 'box' or 'both'.",
call. = FALSE)}
### Start: Validation of arguments
ncomp = object$ncomp
if (any(class.object %in% object.blocks))
{
if (is.null(blocks))
{
blocks = names(object$X)#names$blocks
if (any(class.object == "DA"))
blocks = names(object$X)#blocks[-object$indY]
} else if (is.numeric(blocks) & min(blocks) > 0 & max(blocks) <= length(object$names$blocks)) {
blocks = object$names$blocks[blocks]
} else if (is.character(blocks)) {
if (!any(blocks %in% object$names$blocks))
stop("One element of 'blocks' does not match with the names of the blocks")
} else {
stop("Incorrect value for 'blocks'", call. = FALSE)
}
object$variates = object$variates[names(object$variates) %in% blocks]
object$names$colnames = object$names$colnames[names(object$names$colnames) %in% blocks]
object$blocks = object$X[names(object$X) %in% blocks]
if (any(object$ncomp[blocks] == 1))
{
stop(paste("The number of components for one selected block '", paste(blocks, collapse = " - "),"' is 1. The number of components must be superior or equal to 2."), call. = FALSE)
}
ncomp = object$ncomp[blocks]
} else if (any(class.object %in% c("rcc", "pls", "spls", "mlspls")) & all(class.object !="DA")) {
blocks = c("X", "Y")
} else {
blocks = "X"
}
#-- ellipse.level
if (!is.numeric(rad.in) | (rad.in > 1) | (rad.in < 0))
stop("The value taken by 'rad.in' must be between 0 and 1", call. = FALSE)
#-- cutoff correlation
if (!is.numeric(cutoff) | (cutoff > 1) | (cutoff < 0))
stop("The value taken by 'cutoff' must be between 0 and 1", call. = FALSE)
#-- comp
if(is.null(comp))
{
if (style=="3d")
{
comp = c(1:3)
} else {
comp = c(1:2)
}
}
if (length(comp) != 2 && !(style=="3d"))
{
stop("'comp' must be a numeric vector of length 2.", call. = FALSE)
} else if(length(comp) != 3 && (style=="3d")) {
stop("'comp' must be a numeric vector of length 3.", call. = FALSE)
}
if (!is.numeric(comp))
stop("Invalid vector for 'comp'.")
if (any(ncomp < max(comp)) || min(comp) <= 0)
stop("Each element of 'comp' must be positive smaller or equal than ", min(object$ncomp), ".", call. = FALSE)
comp1 = round(comp[1])
comp2 = round(comp[2])
if (style=="3d")
comp3 = round(comp[3])
#-- comp.select
if (!is.null(comp.select))
{
if (!is.numeric(comp.select))
stop("Invalid vector for 'comp'.", call. = FALSE)
if (any(ncomp < max(comp.select)) || min(comp.select) <= 0)
stop("Each element of 'comp.select' must be positive and smaller or equal than ", max(object$ncomp), ".", call. = FALSE)
} else {
comp.select = comp
}
#-- abline
if (length(abline) > 1)
{
stop("'abline' must be single logical value.", call. = FALSE)
}else if (!is.logical(abline)) {
stop("'abline' must be logical.", call. = FALSE)
}
#-- legend
if (length(legend) != 1 || !is.logical(legend))
stop("'legend' must be a logical value.", call. = FALSE)
#-- Start: Retrieve variates from object
cord.X = sample.X = ind.var.sel = list()
if(style=="3d")
{
if (any(class.object%in% c(object.pls, object.blocks)))
{
if (any(class.object == "rcc"))
{
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2, comp3)] + object$variates$Y[, c(comp1, comp2, comp3)], use = "pairwise")
cord.X[[2]] = cor(object$Y, object$variates$X[, c(comp1, comp2, comp3)] + object$variates$Y[, c(comp1, comp2, comp3)], use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% "plsda")) {
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2, comp3)], use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% "pls")) {
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2, comp3)], use = "pairwise")
cord.X[[2]] = cor(object$Y, if(object$mode == "canonical"){object$variates$Y[, c(comp1, comp2, comp3)]} else {object$variates$X[, c(comp1, comp2, comp3)]}, use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% c("splsda", "mlsplsda"))) {
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(unique(c(comp1, comp2, comp3, comp.select)), function(x){selectVar(object, comp = x)$name})))], # variables selected at least once on unique(comp1, comp2, comp3 and comp.select
object$variates$X[, c(comp1, comp2, comp3, comp.select)], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
if (!is.null(comp.select))
{
cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$name}))), ,drop = FALSE]
}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
} else if (any(class.object %in% c("spls", "mlspls"))) {
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(c(comp1, comp2, comp3), function(x){selectVar(object, comp = x)$X$name})))],
object$variates$X[, c(comp1, comp2, comp3)], use = "pairwise")
cord.X[[2]] = cor(object$Y[, colnames(object$Y) %in% unique(unlist(lapply(c(comp1, comp2, comp3), function(x){selectVar(object, comp = x)$Y$name})))],
if(object$mode == "canonical"){object$variates$Y[, c(comp1, comp2, comp3)]} else {object$variates$X[, c(comp1, comp2, comp3)]}, use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
ind.var.sel[[2]] = sample.X[[2]] = 1 : length(colnames(object$Y))
if (!is.null(comp.select)) {
cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$X$name}))), ,drop = FALSE]
cord.X[[2]] = cord.X[[2]][row.names(cord.X[[2]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$Y$name}))), , drop = FALSE]
}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
ind.var.sel[[2]] = which(colnames(object$Y) %in% rownames(cord.X[[2]]))
} else {
cord.X = lapply(blocks, function(x){cor(object$blocks[[x]], object$variates[[x]][, c(comp1, comp2, comp3)], use = "pairwise")})
ind.var.sel = sample.X = lapply(object$blocks, function(x){1 : ncol(x)})
if (!is.null(comp.select)) {
cord.X = lapply(1 : length(cord.X), function(z){cord.X[[z]][row.names(cord.X[[z]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, block = z, comp = x)[[1]]$name}))), ,drop = FALSE]})
}
for (i in 1 : length(cord.X)){
ind.var.sel[[i]] = which(colnames(object$X) %in% rownames(cord.X[[i]]))
}
}
} else if (any(class.object %in% object.pca)) {
if (any(class.object %in% c("sipca", "spca"))){
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(c(comp1, comp2, comp3), function(x){selectVar(object, comp = x)$name})))],
object$x[, c(comp1, comp2, comp3)], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
if (!is.null(comp.select)) {
cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$name}))), ,drop = FALSE]
}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
} else {
cord.X[[1]] = cor(object$X, object$x[, c(comp1, comp2, comp3)], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
}
}
} else {
if (any(class.object %in% c(object.pls, object.blocks)))
{
if (any(class.object == "rcc"))
{
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2)] + object$variates$Y[, c(comp1, comp2)], use = "pairwise")
cord.X[[2]] = cor(object$Y, object$variates$X[, c(comp1, comp2)] + object$variates$Y[, c(comp1, comp2)], use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% "plsda")) {
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2)], use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% "pls")) {
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2)], use = "pairwise")
cord.X[[2]] = cor(object$Y, if(object$mode == "canonical"){object$variates$Y[, c(comp1, comp2)]} else {object$variates$X[, c(comp1, comp2)]}, use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% c("splsda", "mlsplsda"))) {
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(comp.select, function(x){selectVar(object, comp = x)$name}))), drop = FALSE],
object$variates$X[, unique(c(comp1, comp2))], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
#if (!is.null(comp.select)) {
# cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$name}))), ,drop = FALSE]
#}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
} else if (any(class.object %in% c("spls", "mlspls"))) {
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(comp.select, function(x){selectVar(object, comp = x)$X$name}))), drop = FALSE],
object$variates$X[, c(comp1, comp2)], use = "pairwise")
cord.X[[2]] = cor(object$Y[, colnames(object$Y) %in% unique(unlist(lapply(comp.select, function(x){selectVar(object, comp = x)$Y$name}))), drop = FALSE],
if(object$mode == "canonical")
{
object$variates$Y[, c(comp1, comp2)]
} else {
object$variates$X[, c(comp1, comp2)]
}, use = "pairwise")
#ind.var.sel[[1]] =
sample.X[[1]] = 1 : length(colnames(object$X))
#ind.var.sel[[2]] =
sample.X[[2]] = 1 : length(colnames(object$Y))
#if (!is.null(comp.select)) {
# cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$X$name}))), ,drop = FALSE]
# cord.X[[2]] = cord.X[[2]][row.names(cord.X[[2]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$Y$name}))), , drop = FALSE]
#}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
ind.var.sel[[2]] = which(colnames(object$Y) %in% rownames(cord.X[[2]]))
} else { #block object
cord.X = lapply(blocks, function(x){cor(object$blocks[[x]], object$variates[[x]][, c(comp1, comp2)], use = "pairwise")})
ind.var.sel = sample.X = lapply(object$blocks, function(x){1 : ncol(x)})
if (!is.null(comp.select))
{
cord.X = lapply(1 : length(cord.X), function(z){cord.X[[z]][row.names(cord.X[[z]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, block = blocks[z], comp = x)[[1]]$name}))), ,drop = FALSE]})
}
for (i in 1 : length(cord.X))
{
ind.var.sel[[i]] = which(colnames(object$blocks[[i]]) %in% rownames(cord.X[[i]]))
}
}
} else if (any(class.object %in% object.pca)) {
if (any(class.object %in% c("sipca", "spca"))){
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(comp.select, function(x){selectVar(object, comp = x)$name}))), drop = FALSE],
object$x[, c(comp1, comp2)], use = "pairwise")
#ind.var.sel[[1]] =
sample.X[[1]] = 1 : length(colnames(object$X))
#if (!is.null(comp.select)) {
# cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$name}))), ,drop = FALSE]
#}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
} else {
cord.X[[1]] = cor(object$X, object$x[, c(comp1, comp2)], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
}
}}
# output a message if some variates are anti correlated among blocks
if (any(class.object %in% object.blocks))
{
VarX = lapply(1:2, function(j){do.call(cbind, lapply(object$variates, function(i) i[, comp[j]]))})
corX = lapply(VarX, cor)
if(any(sapply(corX, function(j){any(j < 0)})))
warning("We detected negative correlation between the variates of some blocks, which means that some clusters of variables observed on the correlation circle plot are not necessarily positively correlated.")
}
if (any(sapply(cord.X, nrow) == 0))
stop("No variable selected on at least one block")
#-- End: Retrieve variates from object
#-- Names of labels X and Y
if (is.null(X.label)) X.label = paste("Component ", comp1)
if (is.null(Y.label)) Y.label = paste("Component ", comp2)
if (is.null(Z.label) && style=="3d") Z.label = paste("Component ", comp3)
if (!is.character(X.label))
stop("'X.label' must be a character.", call. = FALSE)
if (!is.character(Y.label))
stop("'Y.label' must be a character.", call. = FALSE)
#-- pch argument
missing.pch = FALSE
if (missing(pch))
{
missing.pch = TRUE
if(style=="3d")
{
pch = unlist(lapply(1 : length(cord.X), function(x){rep(c("sphere", "tetra", "cube", "octa", "icosa", "dodeca")[x], sum(sapply(cord.X[x], nrow)))}))
} else {
pch = unlist(lapply(1 : length(cord.X), function(x){rep(c(1:20)[x], sum(sapply(cord.X[x], nrow)))}))
}
} else if (((is.vector(pch, mode = "double") || is.vector(pch, mode = "integer")) && !(style=="3d"))
|| (is.vector(pch, mode = "character") && style=="3d")) {
if (length(pch) != length(sample.X))
stop.message('pch', sample.X)
pch = unlist(lapply(1 : length(cord.X), function(x){rep(pch[x], sum(sapply(cord.X[x], nrow)))}))
} else if (is.list(pch)) {
if (length(pch) != length(sample.X) || length(unlist(pch)) != sum(sapply(sample.X, length)))
stop.message('pch', sample.X)
if (length(ind.var.sel) != 0)
pch = lapply(1 : length(pch), function(x){pch[[x]][ind.var.sel[[x]]]})
pch = unlist(pch)
} else if (style=="3d") {
if (!all(pch %in% c("sphere", "tetra", "cube", "octa", "icosa", "dodeca")) && style=="3d")
stop("pch' must be a simple character or character vector from {'sphere', 'tetra', 'cube', 'octa', 'icosa', 'dodeca'}.",
call. = FALSE)
}
else {
stop.message('pch', sample.X)
}
#-- col argument
if (missing(col)) {
if (length(cord.X) < 10) {
col = unlist(lapply(1 : length(cord.X), function(x){rep(color.mixo(x), sum(sapply(cord.X[x], nrow)))}))
} else {
col = unlist(lapply(1 : length(cord.X), function(x){rep(color.jet(length(cord.X))[x], sum(sapply(cord.X[x], nrow)))}))
}
} else if (is.vector(col, mode = "double") | is.vector(col, mode = "character")) {
if (length(col) != length(sample.X))
stop.message('col', sample.X)
col = unlist(lapply(1 : length(cord.X), function(x){rep(col[x], sum(sapply(cord.X[x], nrow)))}))
} else if (is.list(col)) {
if (length(col) != length(sample.X) || length(unlist(col)) != sum(sapply(sample.X, length)))
stop.message('col', sample.X)
if (length(ind.var.sel) != 0)
col = lapply(1 : length(col), function(x){col[[x]][ind.var.sel[[x]]]})
col = unlist(col)
} else {
stop.message('col', sample.X)
}
#-- cex argument
if (missing(cex)){
if (style == "ggplot2"){
cex = rep(5, sum(sapply(cord.X, nrow)))
} else {
cex = rep(1, sum(sapply(cord.X, nrow)))
}
} else if (is.vector(cex, mode = "double")) {
if (length(cex) != length(cord.X))
stop.message('cex', sample.X)
cex = unlist(lapply(1 : length(cord.X), function(x){rep(cex[x], sum(sapply(cord.X[x], nrow)))}))
} else if (is.list(cex)) {
if (length(cex) != length(sample.X) || length(unlist(cex)) != sum(sapply(sample.X, length)))
stop.message('cex', sample.X)
if (length(ind.var.sel) != 0)
cex = lapply(1 : length(cex), function(x){cex[[x]][ind.var.sel[[x]]]})
cex = unlist(cex)
} else {
stop.message('cex', sample.X)
}
#-- font argument
if (missing(font)) {
font = rep(1, sum(sapply(cord.X, nrow)))
} else if (is.vector(font, mode = "numeric")) {
if (length(font) != length(cord.X))
stop.message('font', sample.X)
font = unlist(lapply(1 : length(cord.X), function(x){rep(font[x], sum(sapply(cord.X[x], nrow)))}))
} else if (is.list(font)) {
if (length(font) != length(sample.X) || length(unlist(font)) != sum(sapply(sample.X, length)))
stop.message('font', sample.X)
if (length(ind.var.sel) != 0)
font = lapply(1 : length(font), function(x){font[[x]][ind.var.sel[[x]]]})
font = unlist(font)
} else {
stop.message('font', sample.X)
}
#-- var.names
ind.group = cumsum(c(0, sapply(cord.X, nrow)))
if (is.null(var.names)){
var.names.list = unlist(sapply(cord.X, rownames))
if (!missing.pch) {
var.names = rep(FALSE, length(cord.X))
} else {
var.names = rep(TRUE, length(cord.X))
}
} else if (is.vector(var.names, mode = "logical")) {
if (length(var.names) == 1){
var.names = rep(var.names,length(cord.X))}
else if (length(var.names) != length(cord.X))
stop.message('var.names', sample.X)
var.names.list = unlist(lapply(1 : length(var.names), function(x){if(var.names[x]){rownames(cord.X[[x]])}
else {pch[(ind.group[x] + 1) : ind.group[x + 1]]}}))
} else if (is.list(var.names)) {
if (length(var.names) != length(cord.X))
stop.message('var.names', sample.X)
if (sum(sapply(1 : length(var.names), function(x){if(!lapply(var.names, is.logical)[[x]]){
if(is.null(ind.var.sel[[x]])){
length(var.names[[x]])
} else {
length(var.names[[x]][ind.var.sel[[x]]])
}
} else {0}})) !=
sum(sapply(1 : length(var.names), function(x){if(!lapply(var.names, is.logical)[[x]]){nrow(cord.X[[x]])}else {0}}))){
stop.message('var.names', sample.X)
}
var.names.list = unlist(sapply(1 : length(var.names), function(x){if(lapply(var.names, is.logical)[[x]]){
if (var.names[[x]]) {
row.names(cord.X[[x]])
} else {
pch[(ind.group[x] + 1) : ind.group[x + 1]]
}
} else {
if (is.null(ind.var.sel[[x]])){
as.character(var.names[[x]])
} else {
as.character(var.names[[x]])[ind.var.sel[[x]]]
}
}
}))
var.names = sapply(var.names, function(x){if(is.logical(x)){x}else{TRUE}})
} else {
stop.message('var.names', sample.X)
}
#-- Start: Computation ellipse
circle = list()
circle[[1]] = ellipse(0, levels = 1, t = 1)
circle[[2]] = ellipse(0, levels = 1, t = rad.in)
circle = data.frame(do.call("rbind", circle), "Circle" = c(rep("Main circle", 100), rep("Inner circle", 100)))
#-- End: Computation ellipse
#-- Start: data set
df = data.frame(do.call(rbind, cord.X), "Block" = paste0("Block: ", unlist(lapply(1 : length(cord.X), function(z){rep(blocks[z], nrow(cord.X[[z]]))}))))
if (style=="3d")
names(df)[1:3] = c("x", "y","z")
else
names(df)[1:2] = c("x", "y")
df$names = as.vector(var.names.list)
df$pch = pch; df$cex = cex; df$col = col; df$font = font
if(missing.pch)
df$pch=1
if (overlap)
{
df$Overlap = title
df$Block = factor(unlist(lapply(1 : length(cord.X), function(z){rep(blocks[z], nrow(cord.X[[z]]))})))
if(style %in%c("ggplot2","lattice"))
title=NULL # to avoid double title
} else {
df$Overlap = df$Block
if(style %in%c("ggplot2","lattice"))
df$Block = factor(unlist(lapply(1 : length(cord.X), function(z){rep(blocks[z], nrow(cord.X[[z]]))})))
}
if (cutoff != 0){
if(style=="3d")
df = df[abs(df$x) > cutoff | abs(df$y) > cutoff | abs(df$z) > cutoff, ,drop = FALSE]
else
df = df[abs(df$x) > cutoff | abs(df$y) > cutoff, ,drop = FALSE]
ind.group = c(0, cumsum(table(df$Block)[unique(df$Block)])) # add unique to have names of cumsum matching the order of the blocks in df
}
if (nrow(df) == 0)
stop("Cutoff value very high for the components ", comp1, " and ", comp2, ".No variable was selected.")
#-- End: data set
#save(list=ls(),file="temp.Rdata")
#-- Start: ggplot2
if (style == "ggplot2" & plot)
{
Block = NULL# R check
# visible variable issues for x, y and Circle
# according to http://stackoverflow.com/questions/9439256/how-can-i-handle-r-cmd-check-no-visible-binding-for-global-variable-notes-when
# one hack is to set to NULL first.
x = y = Circle = NULL
#-- Initialise ggplot2
p = ggplot(df, aes(x = x, y = y, color = Block), main = title, xlab = X.label, ylab = Y.label)+ theme_bw()
for (i in levels(df$Block))
{
p = p + geom_point(data = subset(df, df$Block == i), size = 0, shape = 0)
}
#-- Display sample or var.names
for (i in 1 : length(var.names)){
if (var.names[i]) {
p = p + geom_text(data = df[c((ind.group[i] + 1) : ind.group[i + 1]), ],
label = df[c((ind.group[i] + 1) : ind.group[i + 1]), "names"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
color = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
fontface = df[c((ind.group[i] + 1) : ind.group[i + 1]), "font"])
} else {
p = p + geom_point(data = df[c((ind.group[i] + 1) : ind.group[i + 1]), ],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
shape = df[c((ind.group[i] + 1) : ind.group[i + 1]), "pch"],
color = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"])
}
}
#-- Modify scale colour - Change X/Ylabel - split plots into Blocks
p = p + scale_colour_manual(values = unique(col)[match(levels(factor(as.character(df$Block))), levels(df$Block))], name = "Block", breaks = levels(df$Block))
p = p + scale_x_continuous(limits = c(-1, 1)) + scale_y_continuous(limits = c(-1, 1))
p = p + labs(list(title = title, x = X.label, y = Y.label)) + facet_wrap(~ Overlap, ncol = 2, as.table = TRUE)
#-- Legend
if (!legend)
{
p = p + theme(legend.position="none")
} else {
p = p + guides(colour = guide_legend(override.aes = list(shape = 19, size = unique(df$cex))))
}
#-- abline
if (abline)
p = p + geom_vline(aes(xintercept = 0), linetype = 2, colour = "darkgrey") + geom_hline(aes(yintercept = 0),linetype = 2,colour = "darkgrey")
#-- circle correlation
for (i in c("Main circle", "Inner circle")){
p = p + geom_path(data = subset(circle, Circle == i), aes_string(x = "x", y = "y"), color = "Black")
}
# p = p + scale_colour_manual(values = levels(factor(df$col))) + scale_shape_manual(values = as.numeric(levels(factor(df$pch)))) + scale_size_discrete(range = range(df$cex))
print(p)
}
#-- End: ggplot2
#-- Start: Lattice
if(style == "lattice" )
{
legend.lattice = list(space = "right", title = "Block", cex.title = 1.25,
points=list(col=unique(df$col),cex = unique(df$cex),pch = unique(df$pch)),
text = list(blocks))
if (overlap) {
p = xyplot(y ~ x | Overlap, data = df, xlab = X.label, ylab = Y.label, main = title,
scales = list(x = list(relation = "free", limits = c(-1, 1)),
y = list(relation = "free", limits = c(-1, 1))),
key=if (legend) {legend.lattice} else {NULL},
panel = function(x, y, ...) {
#-- Abline
if (abline) {panel.abline(v = 0, lty = 2, col = "darkgrey")
panel.abline(h = 0, lty = 2, col = "darkgrey")}
#-- Display sample or row.names
for (i in 1 : length(var.names)){
if (var.names[i]) {
panel.text(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
df[c((ind.group[i] + 1) : ind.group[i + 1]), "names"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
font = df[c((ind.group[i] + 1) : ind.group[i + 1]), "font"])
} else {
panel.points(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
pch = df[c((ind.group[i] + 1) : ind.group[i + 1]), "pch"])
}
}
})
print(p)
panels = trellis.currentLayout(which = "panel")
ind = which(panels == 1, arr.ind = TRUE)
trellis.focus("panel",ind[2], ind[1],highlight = FALSE)
for (i in 1 : length(c("Main circle", "Inner circle"))){
panel.lines(x = circle[circle$Circle %in% c("Main circle", "Inner circle")[i], "x"],
y = circle[circle$Circle %in% c("Main circle", "Inner circle")[i], "y"],
col = "black")
}
trellis.unfocus()
} else {
p = xyplot(y ~ x | Block, data = df, xlab = X.label, ylab = Y.label, main = title, as.table = TRUE,
scales = list(x = list(relation = "free", limits = c(-1, 1)),
y = list(relation = "free", limits = c(-1, 1))),
col = "white",
key=if (legend) {legend.lattice} else {NULL},
)
print(p)
panels = trellis.currentLayout(which = "panel")
for (k in 1 : length(cord.X)) {
ind = which(panels == k, arr.ind = TRUE)
trellis.focus("panel",ind[2], ind[1],highlight = FALSE)
if (var.names[k]){
panel.text(x = df[c((ind.group[k] + 1) : ind.group[k + 1]), "x"],
y = df[c((ind.group[k] + 1) : ind.group[k + 1]), "y"],
df[c((ind.group[k] + 1) : ind.group[k + 1]), "names"],
col = df[c((ind.group[k] + 1) : ind.group[k + 1]), "col"],
cex = df[c((ind.group[k] + 1) : ind.group[k + 1]), "cex"],
font = df[c((ind.group[k] + 1) : ind.group[k + 1]), "font"])
} else {
panel.points(x = df[c((ind.group[k] + 1) : ind.group[k + 1]), "x"],
y = df[c((ind.group[k] + 1) : ind.group[k + 1]), "y"],
col = df[c((ind.group[k] + 1) : ind.group[k + 1]), "col"],
cex = df[c((ind.group[k] + 1) : ind.group[k + 1]), "cex"],
pch = df[c((ind.group[k] + 1) : ind.group[k + 1]), "pch"])
}
for (i in 1 : length(c("Main circle", "Inner circle"))){
panel.lines(x = circle[circle$Circle %in% c("Main circle", "Inner circle")[i], "x"],
y = circle[circle$Circle %in% c("Main circle", "Inner circle")[i], "y"],
col = "black")
}
}
trellis.unfocus()
}
}
#-- End: Lattice
#-- Start: graphics
if(style=="graphics" )
{
if (overlap)
{
if(legend){
opar = par(no.readonly = TRUE)
par(mai=c( 1.360000, 1.093333, 1.093333,max(strwidth("Legend","inches"),max(strwidth(blocks,"inches"))+0.3)+0.2),xpd=TRUE)
}
plot(df$x, df$y, type = "n", xlab = X.label, ylab = Y.label, main = "", xlim = c(-1, 1), ylim = c(-1, 1))
#-- Display sample or row.names
for (i in 1 : length(var.names)){
if (var.names[i]) {
text(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
labels = df[c((ind.group[i] + 1) : ind.group[i + 1]), "names"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
font = df[c((ind.group[i] + 1) : ind.group[i + 1]), "font"])
} else {
points(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
pch = df[c((ind.group[i] + 1) : ind.group[i + 1]), "pch"])
}
}
#-- legend
if (legend)
legend(x = 1.09, y=0.2,
legend = blocks,
title="Block",
col = unique(df$col),
pch = unique(df$pch),
pt.cex = unique(df$cex),
bty = "n")
#-- Abline
if (abline)
abline(v = 0, h = 0, lty = 2, xpd = FALSE)
#-- Ellipse
for (i in c("Main circle", "Inner circle")){
lines(x = circle[circle$Circle == i, "x"], y = circle[circle$Circle == i, "y"], col = "black")
}
title(title)#, outer = TRUE, line = -1)
if (legend) par(mai = opar$mai, xpd = opar$xpd)
} else {
opar <- par()[! names(par()) %in% c("cin", "cra", "csi", "cxy", "din", "page")]
#-- Define layout
mat = matrix(1 : (ceiling(length(cord.X)/2) * 2), ceiling(length(cord.X)/2), min(length(cord.X), 2), byrow = TRUE)
if (legend){
mat = matrix(rep(mat,each=2),nrow=nrow(mat),byrow=T)
mat = cbind(mat,rep(max(mat) + 1, nrow(mat)))
}
layout(mat)
for (k in 1 : length(cord.X)){
#-- initialise plot
plot(df[df$Block %in% paste0("Block: ", blocks[k]), "x" ],
df[df$Block %in% paste0("Block: ", blocks[k]), "y" ],
type = "n", xlab = X.label, ylab = Y.label, main = paste0("Block: ", blocks[k]),
xlim = c(-1, 1), ylim = c(-1, 1))
#-- Display sample or row.names
if (var.names[k]) {
text(x = df[df$Block %in% paste0("Block: ", blocks[k]), "x"],
y = df[df$Block %in% paste0("Block: ", blocks[k]), "y"],
labels = df[df$Block %in% paste0("Block: ", blocks[k]), "names"],
col = df[df$Block %in% paste0("Block: ", blocks[k]), "col"],
cex = df[df$Block %in% paste0("Block: ", blocks[k]), "cex"],
font = df[df$Block %in% paste0("Block: ", blocks[k]), "font"])
} else {
points(x = df[df$Block %in% paste0("Block: ", blocks[k]), "x"],
y = df[df$Block %in% paste0("Block: ", blocks[k]), "y"],
col = df[df$Block %in% paste0("Block: ", blocks[k]), "col"],
cex = df[df$Block %in% paste0("Block: ", blocks[k]), "cex"],
pch = df[df$Block %in% paste0("Block: ", blocks[k]), "pch"])
}
#-- Abline
if (abline)
abline(v = 0, h = 0, lty = 2, xpd = FALSE)
#-- Ellipse
for (i in c("Main circle", "Inner circle")){
lines(x = circle[circle$Circle == i, "x"], y = circle[circle$Circle == i, "y"], col = "black")
}
}
title(title, outer = TRUE, line = -1)
if (length(cord.X) != max(mat) & length(cord.X) != 1){
for (i in 1 : (max(mat)-length(cord.X))){
plot(1,1, type = "n", axes = FALSE, ann = FALSE)
}
}
if (legend)
legend("center",
legend = blocks,
title="Block",
col = unique(df$col),
pch = unique(df$pch),
cex = unique(df$cex),
bty = "n")
par(opar)
}
}
#-- End: graphics
#-- Start: 3d
if(style=="3d") {
open3d()
par3d(windowRect = c(500, 30, 1100, 630))
Sys.sleep(0.5)
if (!is.null(title)) {
mat = matrix(1:2, 2)
layout3d(mat, heights = c(1, 10), model = "inherit")
next3d()
text3d(0, 0, 0, title)
next3d()
}
par3d(userMatrix = rotationMatrix(pi/80, 1, -1/(100*pi), 0))
if (legend) {
legend3d(x="right",
legend = blocks,
col = unique(col),
pch = rep(16,length(unique(pch))),
pt.cex = unique(cex),
bty="n")
}
if (any(axes.box == "axes") || any(axes.box == "all"))
axes3d(c('x','y','z'), pos = c(0, 0, 0), nticks = 2, at = c(-1.2, 1.2),
tick = FALSE, labels = "")
for (i in 1 : length(var.names)){
if (var.names[i]) {
text3d(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
texts = df[c((ind.group[i] + 1) : ind.group[i + 1]), "names"],
color = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
font = df[c((ind.group[i] + 1) : ind.group[i + 1]), "font"])
} else {
switch(unique(df[c((ind.group[i] + 1) : ind.group[i + 1]), "pch"]),
sphere = plot3d(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"], type = "s",
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"], radius = cex/20, add = TRUE),
tetra = shapelist3d(tetrahedron3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/25),
cube = shapelist3d(cube3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/30),
octa = shapelist3d(octahedron3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/17),
icosa = shapelist3d(icosahedron3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/20),
dodeca = shapelist3d(dodecahedron3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/20))
}
}
par3d(cex = 0.8)
#-- draws axes --#
if (any(axes.box == "axes") || any(axes.box == "all")) {
if (any(label.axes.box == "axes") || any(label.axes.box == "both")) {
text3d(1.2, -0.05, 0, texts = X.label, cex = 0.8, color = "black")
text3d(0, 1.27, 0, texts = Y.label, cex = 0.8, color = "black")
text3d(0, -0.05, 1.2, texts = Z.label, cex = 0.8, color = "black")
}
X = c(1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09,
0.0, 0.0, 0.0, 0.0, 0.035, -0.035, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4), 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4),
0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.035, -0.035, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4))
Y = c(0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.035, -0.035, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4),
1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09,
0.0, 0.035, -0.035, 0.0, 0.0, 0.0, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4), 0.0, -0.035*sin(pi/4), 0.035*sin(pi/4))
Z = c(0.0, 0.035, -0.035, 0.0, 0.035, -0.035, 0.0, 0.0, 0.0, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4),
0.0, 0.035, -0.035, 0.0, 0.0, 0.0, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4), 0.0, -0.035*sin(pi/4), 0.035*sin(pi/4),
1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09)
triangles3d(x = X, y = Y, z = Z, col = "black")
}
points3d(1.2, 0, 0, size = 0.1, alpha = 0)
points3d(0, 1.2, 0, size = 0.1, alpha = 0)
points3d(0, 0, 1.2, size = 0.1, alpha = 0)
points3d(-1.2, 0, 0, size = 0.1, alpha = 0)
points3d(0, -1.2, 0, size = 0.1, alpha = 0)
points3d(0, 0, -1.2, size = 0.1, alpha = 0)
#-- draws sphere --#
spheres3d(0, 0, 0, radius = rad.in, front = "fill", back = "fill", emission = gray(0.9), alpha = 0.4)
spheres3d(0, 0, 0, radius = rad.in, front = "line", back = "line", emission = gray(0.9))
#-- draws axes/box and add axes labels --#
if (any(axes.box == "box") || any(axes.box == "all")) {
axes3d(marklen = 25)
box3d()
if (any(label.axes.box == "box") || any(label.axes.box == "both")) {
mtext3d(X.label, "x-+", line = 1)
mtext3d(Y.label, "y-+", line = 1.5)
mtext3d(Z.label, "z+-", line = 1)
}
}
if (any(axes.box == "bbox") || any(axes.box == "all")) {
bbox3d(color = c("#333377", "black"), emission = gray(0.5),
specular = gray(0.1), shininess = 5, alpha = 0.8, marklen = 25)
if (any(label.axes.box == "box") || any(label.axes.box == "both")) {
mtext3d(X.label, "x-+", line = 1)
mtext3d(Y.label, "y-+", line = 1.5)
mtext3d(Z.label, "z+-", line = 1)
}
}
}
#-- End: graphics
if(plot){
return(invisible(df))}
else
return(df)
}
Try the mixOmics package in your browser
Any scripts or data that you put into this service are public.
mixOmics documentation built on June 1, 2018, 5:06 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions plotVar
Documented in plotVar
#############################################################################################################
# Authors:
# Ignacio Gonzalez, Genopole Toulouse Midi-Pyrenees, France
# Benoit Gautier, The University of Queensland, The University of Queensland Diamantina Institute, Translational Research Institute, Brisbane, QLD
# Francois Bartolo, Institut National des Sciences Appliquees et Institut de Mathematiques, Universite de Toulouse et CNRS (UMR 5219), France
# Florian Rohart, The University of Queensland Diamantina Institute, Translational Research Institute, Brisbane, QLD
# Kim-Anh Le Cao, The University of Queensland Diamantina Institute, Translational Research Institute, Brisbane, QLD
#
# created: 2009
# last modified: 24-08-2016
#
# Copyright (C) 2009
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
# last modified: 01-03-2016
#----------------------------------------------------------------------------------------------------------#
#-- Includes plotVar for PLS, sPLS, PLS-DA, SPLS-DA, rCC, PCA, sPCA, IPCA, sIPCA, rGCCA, sGCCA, sGCCDA --#
#----------------------------------------------------------------------------------------------------------#
plotVar <-
function(object,
comp = NULL,
comp.select = comp,
plot = TRUE,
var.names = NULL,
blocks = NULL, # to choose which block data to plot, when using GCCA module
X.label = NULL,
Y.label = NULL,
Z.label = NULL,
abline = TRUE,
col,
cex,
pch,
font,
cutoff = 0,
rad.in = 0.5,
title = "Correlation Circle Plots",
legend = FALSE,
style="ggplot2", # can choose between graphics,3d, lattice or ggplot2,
overlap = TRUE,
axes.box = "all",
label.axes.box = "both" )
{
class.object = class(object)
object.pls=c("pls","spls","mlspls","mlsplsda","rcc")
object.pca=c("ipca","sipca","pca","spca")
object.blocks=c("sgcca","rgcca")
#-- check that the user did not enter extra arguments
arg.call = match.call()
user.arg = names(arg.call)[-1]
err = tryCatch(mget(names(formals()), sys.frame(sys.nframe())),
error = function(e) e)
if ("simpleError" %in% class(err))
stop(err[[1]], ".", call. = FALSE)
#-- style
if (!style %in% c("ggplot2", "lattice", "graphics","3d"))
stop("'style' must be one of 'ggplot2', '3d' , lattice' or 'graphics'.", call. = FALSE)
#-- plot
if (length(plot) > 1)
stop("'plot' must be single logical value.", call. = FALSE)
else if (!is.logical(plot))
stop("'plot' must be logical.", call. = FALSE)
if(!plot)
{
style="N"}
#-- axes.box
if(style=="3d")
{
choices = c("axes", "box", "bbox", "all")
axes.box = choices[pmatch(axes.box, choices)]
if (is.na(axes.box))
stop("'axes.box' should be a subset of {'axes', 'box', 'bbox', 'all'}.",
call. = FALSE)
#-- label.axes.box
choices = c("axes", "box", "both")
label.axes.box = choices[pmatch(label.axes.box, choices)]
if (is.na(label.axes.box))
stop("'label.axes.box' should be one of 'axes', 'box' or 'both'.",
call. = FALSE)}
### Start: Validation of arguments
ncomp = object$ncomp
if (any(class.object %in% object.blocks))
{
if (is.null(blocks))
{
blocks = names(object$X)#names$blocks
if (any(class.object == "DA"))
blocks = names(object$X)#blocks[-object$indY]
} else if (is.numeric(blocks) & min(blocks) > 0 & max(blocks) <= length(object$names$blocks)) {
blocks = object$names$blocks[blocks]
} else if (is.character(blocks)) {
if (!any(blocks %in% object$names$blocks))
stop("One element of 'blocks' does not match with the names of the blocks")
} else {
stop("Incorrect value for 'blocks'", call. = FALSE)
}
object$variates = object$variates[names(object$variates) %in% blocks]
object$names$colnames = object$names$colnames[names(object$names$colnames) %in% blocks]
object$blocks = object$X[names(object$X) %in% blocks]
if (any(object$ncomp[blocks] == 1))
{
stop(paste("The number of components for one selected block '", paste(blocks, collapse = " - "),"' is 1. The number of components must be superior or equal to 2."), call. = FALSE)
}
ncomp = object$ncomp[blocks]
} else if (any(class.object %in% c("rcc", "pls", "spls", "mlspls")) & all(class.object !="DA")) {
blocks = c("X", "Y")
} else {
blocks = "X"
}
#-- ellipse.level
if (!is.numeric(rad.in) | (rad.in > 1) | (rad.in < 0))
stop("The value taken by 'rad.in' must be between 0 and 1", call. = FALSE)
#-- cutoff correlation
if (!is.numeric(cutoff) | (cutoff > 1) | (cutoff < 0))
stop("The value taken by 'cutoff' must be between 0 and 1", call. = FALSE)
#-- comp
if(is.null(comp))
{
if (style=="3d")
{
comp = c(1:3)
} else {
comp = c(1:2)
}
}
if (length(comp) != 2 && !(style=="3d"))
{
stop("'comp' must be a numeric vector of length 2.", call. = FALSE)
} else if(length(comp) != 3 && (style=="3d")) {
stop("'comp' must be a numeric vector of length 3.", call. = FALSE)
}
if (!is.numeric(comp))
stop("Invalid vector for 'comp'.")
if (any(ncomp < max(comp)) || min(comp) <= 0)
stop("Each element of 'comp' must be positive smaller or equal than ", min(object$ncomp), ".", call. = FALSE)
comp1 = round(comp[1])
comp2 = round(comp[2])
if (style=="3d")
comp3 = round(comp[3])
#-- comp.select
if (!is.null(comp.select))
{
if (!is.numeric(comp.select))
stop("Invalid vector for 'comp'.", call. = FALSE)
if (any(ncomp < max(comp.select)) || min(comp.select) <= 0)
stop("Each element of 'comp.select' must be positive and smaller or equal than ", max(object$ncomp), ".", call. = FALSE)
} else {
comp.select = comp
}
#-- abline
if (length(abline) > 1)
{
stop("'abline' must be single logical value.", call. = FALSE)
}else if (!is.logical(abline)) {
stop("'abline' must be logical.", call. = FALSE)
}
#-- legend
if (length(legend) != 1 || !is.logical(legend))
stop("'legend' must be a logical value.", call. = FALSE)
#-- Start: Retrieve variates from object
cord.X = sample.X = ind.var.sel = list()
if(style=="3d")
{
if (any(class.object%in% c(object.pls, object.blocks)))
{
if (any(class.object == "rcc"))
{
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2, comp3)] + object$variates$Y[, c(comp1, comp2, comp3)], use = "pairwise")
cord.X[[2]] = cor(object$Y, object$variates$X[, c(comp1, comp2, comp3)] + object$variates$Y[, c(comp1, comp2, comp3)], use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% "plsda")) {
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2, comp3)], use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% "pls")) {
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2, comp3)], use = "pairwise")
cord.X[[2]] = cor(object$Y, if(object$mode == "canonical"){object$variates$Y[, c(comp1, comp2, comp3)]} else {object$variates$X[, c(comp1, comp2, comp3)]}, use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% c("splsda", "mlsplsda"))) {
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(unique(c(comp1, comp2, comp3, comp.select)), function(x){selectVar(object, comp = x)$name})))], # variables selected at least once on unique(comp1, comp2, comp3 and comp.select
object$variates$X[, c(comp1, comp2, comp3, comp.select)], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
if (!is.null(comp.select))
{
cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$name}))), ,drop = FALSE]
}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
} else if (any(class.object %in% c("spls", "mlspls"))) {
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(c(comp1, comp2, comp3), function(x){selectVar(object, comp = x)$X$name})))],
object$variates$X[, c(comp1, comp2, comp3)], use = "pairwise")
cord.X[[2]] = cor(object$Y[, colnames(object$Y) %in% unique(unlist(lapply(c(comp1, comp2, comp3), function(x){selectVar(object, comp = x)$Y$name})))],
if(object$mode == "canonical"){object$variates$Y[, c(comp1, comp2, comp3)]} else {object$variates$X[, c(comp1, comp2, comp3)]}, use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
ind.var.sel[[2]] = sample.X[[2]] = 1 : length(colnames(object$Y))
if (!is.null(comp.select)) {
cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$X$name}))), ,drop = FALSE]
cord.X[[2]] = cord.X[[2]][row.names(cord.X[[2]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$Y$name}))), , drop = FALSE]
}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
ind.var.sel[[2]] = which(colnames(object$Y) %in% rownames(cord.X[[2]]))
} else {
cord.X = lapply(blocks, function(x){cor(object$blocks[[x]], object$variates[[x]][, c(comp1, comp2, comp3)], use = "pairwise")})
ind.var.sel = sample.X = lapply(object$blocks, function(x){1 : ncol(x)})
if (!is.null(comp.select)) {
cord.X = lapply(1 : length(cord.X), function(z){cord.X[[z]][row.names(cord.X[[z]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, block = z, comp = x)[[1]]$name}))), ,drop = FALSE]})
}
for (i in 1 : length(cord.X)){
ind.var.sel[[i]] = which(colnames(object$X) %in% rownames(cord.X[[i]]))
}
}
} else if (any(class.object %in% object.pca)) {
if (any(class.object %in% c("sipca", "spca"))){
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(c(comp1, comp2, comp3), function(x){selectVar(object, comp = x)$name})))],
object$x[, c(comp1, comp2, comp3)], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
if (!is.null(comp.select)) {
cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$name}))), ,drop = FALSE]
}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
} else {
cord.X[[1]] = cor(object$X, object$x[, c(comp1, comp2, comp3)], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
}
}
} else {
if (any(class.object %in% c(object.pls, object.blocks)))
{
if (any(class.object == "rcc"))
{
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2)] + object$variates$Y[, c(comp1, comp2)], use = "pairwise")
cord.X[[2]] = cor(object$Y, object$variates$X[, c(comp1, comp2)] + object$variates$Y[, c(comp1, comp2)], use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% "plsda")) {
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2)], use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% "pls")) {
cord.X[[1]] = cor(object$X, object$variates$X[, c(comp1, comp2)], use = "pairwise")
cord.X[[2]] = cor(object$Y, if(object$mode == "canonical"){object$variates$Y[, c(comp1, comp2)]} else {object$variates$X[, c(comp1, comp2)]}, use = "pairwise")
sample.X = lapply(cord.X, function(x){1 : nrow(x)})
} else if (any(class.object %in% c("splsda", "mlsplsda"))) {
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(comp.select, function(x){selectVar(object, comp = x)$name}))), drop = FALSE],
object$variates$X[, unique(c(comp1, comp2))], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
#if (!is.null(comp.select)) {
# cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$name}))), ,drop = FALSE]
#}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
} else if (any(class.object %in% c("spls", "mlspls"))) {
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(comp.select, function(x){selectVar(object, comp = x)$X$name}))), drop = FALSE],
object$variates$X[, c(comp1, comp2)], use = "pairwise")
cord.X[[2]] = cor(object$Y[, colnames(object$Y) %in% unique(unlist(lapply(comp.select, function(x){selectVar(object, comp = x)$Y$name}))), drop = FALSE],
if(object$mode == "canonical")
{
object$variates$Y[, c(comp1, comp2)]
} else {
object$variates$X[, c(comp1, comp2)]
}, use = "pairwise")
#ind.var.sel[[1]] =
sample.X[[1]] = 1 : length(colnames(object$X))
#ind.var.sel[[2]] =
sample.X[[2]] = 1 : length(colnames(object$Y))
#if (!is.null(comp.select)) {
# cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$X$name}))), ,drop = FALSE]
# cord.X[[2]] = cord.X[[2]][row.names(cord.X[[2]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$Y$name}))), , drop = FALSE]
#}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
ind.var.sel[[2]] = which(colnames(object$Y) %in% rownames(cord.X[[2]]))
} else { #block object
cord.X = lapply(blocks, function(x){cor(object$blocks[[x]], object$variates[[x]][, c(comp1, comp2)], use = "pairwise")})
ind.var.sel = sample.X = lapply(object$blocks, function(x){1 : ncol(x)})
if (!is.null(comp.select))
{
cord.X = lapply(1 : length(cord.X), function(z){cord.X[[z]][row.names(cord.X[[z]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, block = blocks[z], comp = x)[[1]]$name}))), ,drop = FALSE]})
}
for (i in 1 : length(cord.X))
{
ind.var.sel[[i]] = which(colnames(object$blocks[[i]]) %in% rownames(cord.X[[i]]))
}
}
} else if (any(class.object %in% object.pca)) {
if (any(class.object %in% c("sipca", "spca"))){
cord.X[[1]] = cor(object$X[, colnames(object$X) %in% unique(unlist(lapply(comp.select, function(x){selectVar(object, comp = x)$name}))), drop = FALSE],
object$x[, c(comp1, comp2)], use = "pairwise")
#ind.var.sel[[1]] =
sample.X[[1]] = 1 : length(colnames(object$X))
#if (!is.null(comp.select)) {
# cord.X[[1]] = cord.X[[1]][row.names(cord.X[[1]]) %in% unique(unlist(lapply(comp.select, function(x) {selectVar(object, comp = x)$name}))), ,drop = FALSE]
#}
ind.var.sel[[1]] = which(colnames(object$X) %in% rownames(cord.X[[1]]))
} else {
cord.X[[1]] = cor(object$X, object$x[, c(comp1, comp2)], use = "pairwise")
ind.var.sel[[1]] = sample.X[[1]] = 1 : length(colnames(object$X))
}
}}
# output a message if some variates are anti correlated among blocks
if (any(class.object %in% object.blocks))
{
VarX = lapply(1:2, function(j){do.call(cbind, lapply(object$variates, function(i) i[, comp[j]]))})
corX = lapply(VarX, cor)
if(any(sapply(corX, function(j){any(j < 0)})))
warning("We detected negative correlation between the variates of some blocks, which means that some clusters of variables observed on the correlation circle plot are not necessarily positively correlated.")
}
if (any(sapply(cord.X, nrow) == 0))
stop("No variable selected on at least one block")
#-- End: Retrieve variates from object
#-- Names of labels X and Y
if (is.null(X.label)) X.label = paste("Component ", comp1)
if (is.null(Y.label)) Y.label = paste("Component ", comp2)
if (is.null(Z.label) && style=="3d") Z.label = paste("Component ", comp3)
if (!is.character(X.label))
stop("'X.label' must be a character.", call. = FALSE)
if (!is.character(Y.label))
stop("'Y.label' must be a character.", call. = FALSE)
#-- pch argument
missing.pch = FALSE
if (missing(pch))
{
missing.pch = TRUE
if(style=="3d")
{
pch = unlist(lapply(1 : length(cord.X), function(x){rep(c("sphere", "tetra", "cube", "octa", "icosa", "dodeca")[x], sum(sapply(cord.X[x], nrow)))}))
} else {
pch = unlist(lapply(1 : length(cord.X), function(x){rep(c(1:20)[x], sum(sapply(cord.X[x], nrow)))}))
}
} else if (((is.vector(pch, mode = "double") || is.vector(pch, mode = "integer")) && !(style=="3d"))
|| (is.vector(pch, mode = "character") && style=="3d")) {
if (length(pch) != length(sample.X))
stop.message('pch', sample.X)
pch = unlist(lapply(1 : length(cord.X), function(x){rep(pch[x], sum(sapply(cord.X[x], nrow)))}))
} else if (is.list(pch)) {
if (length(pch) != length(sample.X) || length(unlist(pch)) != sum(sapply(sample.X, length)))
stop.message('pch', sample.X)
if (length(ind.var.sel) != 0)
pch = lapply(1 : length(pch), function(x){pch[[x]][ind.var.sel[[x]]]})
pch = unlist(pch)
} else if (style=="3d") {
if (!all(pch %in% c("sphere", "tetra", "cube", "octa", "icosa", "dodeca")) && style=="3d")
stop("pch' must be a simple character or character vector from {'sphere', 'tetra', 'cube', 'octa', 'icosa', 'dodeca'}.",
call. = FALSE)
}
else {
stop.message('pch', sample.X)
}
#-- col argument
if (missing(col)) {
if (length(cord.X) < 10) {
col = unlist(lapply(1 : length(cord.X), function(x){rep(color.mixo(x), sum(sapply(cord.X[x], nrow)))}))
} else {
col = unlist(lapply(1 : length(cord.X), function(x){rep(color.jet(length(cord.X))[x], sum(sapply(cord.X[x], nrow)))}))
}
} else if (is.vector(col, mode = "double") | is.vector(col, mode = "character")) {
if (length(col) != length(sample.X))
stop.message('col', sample.X)
col = unlist(lapply(1 : length(cord.X), function(x){rep(col[x], sum(sapply(cord.X[x], nrow)))}))
} else if (is.list(col)) {
if (length(col) != length(sample.X) || length(unlist(col)) != sum(sapply(sample.X, length)))
stop.message('col', sample.X)
if (length(ind.var.sel) != 0)
col = lapply(1 : length(col), function(x){col[[x]][ind.var.sel[[x]]]})
col = unlist(col)
} else {
stop.message('col', sample.X)
}
#-- cex argument
if (missing(cex)){
if (style == "ggplot2"){
cex = rep(5, sum(sapply(cord.X, nrow)))
} else {
cex = rep(1, sum(sapply(cord.X, nrow)))
}
} else if (is.vector(cex, mode = "double")) {
if (length(cex) != length(cord.X))
stop.message('cex', sample.X)
cex = unlist(lapply(1 : length(cord.X), function(x){rep(cex[x], sum(sapply(cord.X[x], nrow)))}))
} else if (is.list(cex)) {
if (length(cex) != length(sample.X) || length(unlist(cex)) != sum(sapply(sample.X, length)))
stop.message('cex', sample.X)
if (length(ind.var.sel) != 0)
cex = lapply(1 : length(cex), function(x){cex[[x]][ind.var.sel[[x]]]})
cex = unlist(cex)
} else {
stop.message('cex', sample.X)
}
#-- font argument
if (missing(font)) {
font = rep(1, sum(sapply(cord.X, nrow)))
} else if (is.vector(font, mode = "numeric")) {
if (length(font) != length(cord.X))
stop.message('font', sample.X)
font = unlist(lapply(1 : length(cord.X), function(x){rep(font[x], sum(sapply(cord.X[x], nrow)))}))
} else if (is.list(font)) {
if (length(font) != length(sample.X) || length(unlist(font)) != sum(sapply(sample.X, length)))
stop.message('font', sample.X)
if (length(ind.var.sel) != 0)
font = lapply(1 : length(font), function(x){font[[x]][ind.var.sel[[x]]]})
font = unlist(font)
} else {
stop.message('font', sample.X)
}
#-- var.names
ind.group = cumsum(c(0, sapply(cord.X, nrow)))
if (is.null(var.names)){
var.names.list = unlist(sapply(cord.X, rownames))
if (!missing.pch) {
var.names = rep(FALSE, length(cord.X))
} else {
var.names = rep(TRUE, length(cord.X))
}
} else if (is.vector(var.names, mode = "logical")) {
if (length(var.names) == 1){
var.names = rep(var.names,length(cord.X))}
else if (length(var.names) != length(cord.X))
stop.message('var.names', sample.X)
var.names.list = unlist(lapply(1 : length(var.names), function(x){if(var.names[x]){rownames(cord.X[[x]])}
else {pch[(ind.group[x] + 1) : ind.group[x + 1]]}}))
} else if (is.list(var.names)) {
if (length(var.names) != length(cord.X))
stop.message('var.names', sample.X)
if (sum(sapply(1 : length(var.names), function(x){if(!lapply(var.names, is.logical)[[x]]){
if(is.null(ind.var.sel[[x]])){
length(var.names[[x]])
} else {
length(var.names[[x]][ind.var.sel[[x]]])
}
} else {0}})) !=
sum(sapply(1 : length(var.names), function(x){if(!lapply(var.names, is.logical)[[x]]){nrow(cord.X[[x]])}else {0}}))){
stop.message('var.names', sample.X)
}
var.names.list = unlist(sapply(1 : length(var.names), function(x){if(lapply(var.names, is.logical)[[x]]){
if (var.names[[x]]) {
row.names(cord.X[[x]])
} else {
pch[(ind.group[x] + 1) : ind.group[x + 1]]
}
} else {
if (is.null(ind.var.sel[[x]])){
as.character(var.names[[x]])
} else {
as.character(var.names[[x]])[ind.var.sel[[x]]]
}
}
}))
var.names = sapply(var.names, function(x){if(is.logical(x)){x}else{TRUE}})
} else {
stop.message('var.names', sample.X)
}
#-- Start: Computation ellipse
circle = list()
circle[[1]] = ellipse(0, levels = 1, t = 1)
circle[[2]] = ellipse(0, levels = 1, t = rad.in)
circle = data.frame(do.call("rbind", circle), "Circle" = c(rep("Main circle", 100), rep("Inner circle", 100)))
#-- End: Computation ellipse
#-- Start: data set
df = data.frame(do.call(rbind, cord.X), "Block" = paste0("Block: ", unlist(lapply(1 : length(cord.X), function(z){rep(blocks[z], nrow(cord.X[[z]]))}))))
if (style=="3d")
names(df)[1:3] = c("x", "y","z")
else
names(df)[1:2] = c("x", "y")
df$names = as.vector(var.names.list)
df$pch = pch; df$cex = cex; df$col = col; df$font = font
if(missing.pch)
df$pch=1
if (overlap)
{
df$Overlap = title
df$Block = factor(unlist(lapply(1 : length(cord.X), function(z){rep(blocks[z], nrow(cord.X[[z]]))})))
if(style %in%c("ggplot2","lattice"))
title=NULL # to avoid double title
} else {
df$Overlap = df$Block
if(style %in%c("ggplot2","lattice"))
df$Block = factor(unlist(lapply(1 : length(cord.X), function(z){rep(blocks[z], nrow(cord.X[[z]]))})))
}
if (cutoff != 0){
if(style=="3d")
df = df[abs(df$x) > cutoff | abs(df$y) > cutoff | abs(df$z) > cutoff, ,drop = FALSE]
else
df = df[abs(df$x) > cutoff | abs(df$y) > cutoff, ,drop = FALSE]
ind.group = c(0, cumsum(table(df$Block)[unique(df$Block)])) # add unique to have names of cumsum matching the order of the blocks in df
}
if (nrow(df) == 0)
stop("Cutoff value very high for the components ", comp1, " and ", comp2, ".No variable was selected.")
#-- End: data set
#save(list=ls(),file="temp.Rdata")
#-- Start: ggplot2
if (style == "ggplot2" & plot)
{
Block = NULL# R check
# visible variable issues for x, y and Circle
# according to http://stackoverflow.com/questions/9439256/how-can-i-handle-r-cmd-check-no-visible-binding-for-global-variable-notes-when
# one hack is to set to NULL first.
x = y = Circle = NULL
#-- Initialise ggplot2
p = ggplot(df, aes(x = x, y = y, color = Block), main = title, xlab = X.label, ylab = Y.label)+ theme_bw()
for (i in levels(df$Block))
{
p = p + geom_point(data = subset(df, df$Block == i), size = 0, shape = 0)
}
#-- Display sample or var.names
for (i in 1 : length(var.names)){
if (var.names[i]) {
p = p + geom_text(data = df[c((ind.group[i] + 1) : ind.group[i + 1]), ],
label = df[c((ind.group[i] + 1) : ind.group[i + 1]), "names"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
color = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
fontface = df[c((ind.group[i] + 1) : ind.group[i + 1]), "font"])
} else {
p = p + geom_point(data = df[c((ind.group[i] + 1) : ind.group[i + 1]), ],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
shape = df[c((ind.group[i] + 1) : ind.group[i + 1]), "pch"],
color = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"])
}
}
#-- Modify scale colour - Change X/Ylabel - split plots into Blocks
p = p + scale_colour_manual(values = unique(col)[match(levels(factor(as.character(df$Block))), levels(df$Block))], name = "Block", breaks = levels(df$Block))
p = p + scale_x_continuous(limits = c(-1, 1)) + scale_y_continuous(limits = c(-1, 1))
p = p + labs(list(title = title, x = X.label, y = Y.label)) + facet_wrap(~ Overlap, ncol = 2, as.table = TRUE)
#-- Legend
if (!legend)
{
p = p + theme(legend.position="none")
} else {
p = p + guides(colour = guide_legend(override.aes = list(shape = 19, size = unique(df$cex))))
}
#-- abline
if (abline)
p = p + geom_vline(aes(xintercept = 0), linetype = 2, colour = "darkgrey") + geom_hline(aes(yintercept = 0),linetype = 2,colour = "darkgrey")
#-- circle correlation
for (i in c("Main circle", "Inner circle")){
p = p + geom_path(data = subset(circle, Circle == i), aes_string(x = "x", y = "y"), color = "Black")
}
# p = p + scale_colour_manual(values = levels(factor(df$col))) + scale_shape_manual(values = as.numeric(levels(factor(df$pch)))) + scale_size_discrete(range = range(df$cex))
print(p)
}
#-- End: ggplot2
#-- Start: Lattice
if(style == "lattice" )
{
legend.lattice = list(space = "right", title = "Block", cex.title = 1.25,
points=list(col=unique(df$col),cex = unique(df$cex),pch = unique(df$pch)),
text = list(blocks))
if (overlap) {
p = xyplot(y ~ x | Overlap, data = df, xlab = X.label, ylab = Y.label, main = title,
scales = list(x = list(relation = "free", limits = c(-1, 1)),
y = list(relation = "free", limits = c(-1, 1))),
key=if (legend) {legend.lattice} else {NULL},
panel = function(x, y, ...) {
#-- Abline
if (abline) {panel.abline(v = 0, lty = 2, col = "darkgrey")
panel.abline(h = 0, lty = 2, col = "darkgrey")}
#-- Display sample or row.names
for (i in 1 : length(var.names)){
if (var.names[i]) {
panel.text(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
df[c((ind.group[i] + 1) : ind.group[i + 1]), "names"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
font = df[c((ind.group[i] + 1) : ind.group[i + 1]), "font"])
} else {
panel.points(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
pch = df[c((ind.group[i] + 1) : ind.group[i + 1]), "pch"])
}
}
})
print(p)
panels = trellis.currentLayout(which = "panel")
ind = which(panels == 1, arr.ind = TRUE)
trellis.focus("panel",ind[2], ind[1],highlight = FALSE)
for (i in 1 : length(c("Main circle", "Inner circle"))){
panel.lines(x = circle[circle$Circle %in% c("Main circle", "Inner circle")[i], "x"],
y = circle[circle$Circle %in% c("Main circle", "Inner circle")[i], "y"],
col = "black")
}
trellis.unfocus()
} else {
p = xyplot(y ~ x | Block, data = df, xlab = X.label, ylab = Y.label, main = title, as.table = TRUE,
scales = list(x = list(relation = "free", limits = c(-1, 1)),
y = list(relation = "free", limits = c(-1, 1))),
col = "white",
key=if (legend) {legend.lattice} else {NULL},
)
print(p)
panels = trellis.currentLayout(which = "panel")
for (k in 1 : length(cord.X)) {
ind = which(panels == k, arr.ind = TRUE)
trellis.focus("panel",ind[2], ind[1],highlight = FALSE)
if (var.names[k]){
panel.text(x = df[c((ind.group[k] + 1) : ind.group[k + 1]), "x"],
y = df[c((ind.group[k] + 1) : ind.group[k + 1]), "y"],
df[c((ind.group[k] + 1) : ind.group[k + 1]), "names"],
col = df[c((ind.group[k] + 1) : ind.group[k + 1]), "col"],
cex = df[c((ind.group[k] + 1) : ind.group[k + 1]), "cex"],
font = df[c((ind.group[k] + 1) : ind.group[k + 1]), "font"])
} else {
panel.points(x = df[c((ind.group[k] + 1) : ind.group[k + 1]), "x"],
y = df[c((ind.group[k] + 1) : ind.group[k + 1]), "y"],
col = df[c((ind.group[k] + 1) : ind.group[k + 1]), "col"],
cex = df[c((ind.group[k] + 1) : ind.group[k + 1]), "cex"],
pch = df[c((ind.group[k] + 1) : ind.group[k + 1]), "pch"])
}
for (i in 1 : length(c("Main circle", "Inner circle"))){
panel.lines(x = circle[circle$Circle %in% c("Main circle", "Inner circle")[i], "x"],
y = circle[circle$Circle %in% c("Main circle", "Inner circle")[i], "y"],
col = "black")
}
}
trellis.unfocus()
}
}
#-- End: Lattice
#-- Start: graphics
if(style=="graphics" )
{
if (overlap)
{
if(legend){
opar = par(no.readonly = TRUE)
par(mai=c( 1.360000, 1.093333, 1.093333,max(strwidth("Legend","inches"),max(strwidth(blocks,"inches"))+0.3)+0.2),xpd=TRUE)
}
plot(df$x, df$y, type = "n", xlab = X.label, ylab = Y.label, main = "", xlim = c(-1, 1), ylim = c(-1, 1))
#-- Display sample or row.names
for (i in 1 : length(var.names)){
if (var.names[i]) {
text(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
labels = df[c((ind.group[i] + 1) : ind.group[i + 1]), "names"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
font = df[c((ind.group[i] + 1) : ind.group[i + 1]), "font"])
} else {
points(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
pch = df[c((ind.group[i] + 1) : ind.group[i + 1]), "pch"])
}
}
#-- legend
if (legend)
legend(x = 1.09, y=0.2,
legend = blocks,
title="Block",
col = unique(df$col),
pch = unique(df$pch),
pt.cex = unique(df$cex),
bty = "n")
#-- Abline
if (abline)
abline(v = 0, h = 0, lty = 2, xpd = FALSE)
#-- Ellipse
for (i in c("Main circle", "Inner circle")){
lines(x = circle[circle$Circle == i, "x"], y = circle[circle$Circle == i, "y"], col = "black")
}
title(title)#, outer = TRUE, line = -1)
if (legend) par(mai = opar$mai, xpd = opar$xpd)
} else {
opar <- par()[! names(par()) %in% c("cin", "cra", "csi", "cxy", "din", "page")]
#-- Define layout
mat = matrix(1 : (ceiling(length(cord.X)/2) * 2), ceiling(length(cord.X)/2), min(length(cord.X), 2), byrow = TRUE)
if (legend){
mat = matrix(rep(mat,each=2),nrow=nrow(mat),byrow=T)
mat = cbind(mat,rep(max(mat) + 1, nrow(mat)))
}
layout(mat)
for (k in 1 : length(cord.X)){
#-- initialise plot
plot(df[df$Block %in% paste0("Block: ", blocks[k]), "x" ],
df[df$Block %in% paste0("Block: ", blocks[k]), "y" ],
type = "n", xlab = X.label, ylab = Y.label, main = paste0("Block: ", blocks[k]),
xlim = c(-1, 1), ylim = c(-1, 1))
#-- Display sample or row.names
if (var.names[k]) {
text(x = df[df$Block %in% paste0("Block: ", blocks[k]), "x"],
y = df[df$Block %in% paste0("Block: ", blocks[k]), "y"],
labels = df[df$Block %in% paste0("Block: ", blocks[k]), "names"],
col = df[df$Block %in% paste0("Block: ", blocks[k]), "col"],
cex = df[df$Block %in% paste0("Block: ", blocks[k]), "cex"],
font = df[df$Block %in% paste0("Block: ", blocks[k]), "font"])
} else {
points(x = df[df$Block %in% paste0("Block: ", blocks[k]), "x"],
y = df[df$Block %in% paste0("Block: ", blocks[k]), "y"],
col = df[df$Block %in% paste0("Block: ", blocks[k]), "col"],
cex = df[df$Block %in% paste0("Block: ", blocks[k]), "cex"],
pch = df[df$Block %in% paste0("Block: ", blocks[k]), "pch"])
}
#-- Abline
if (abline)
abline(v = 0, h = 0, lty = 2, xpd = FALSE)
#-- Ellipse
for (i in c("Main circle", "Inner circle")){
lines(x = circle[circle$Circle == i, "x"], y = circle[circle$Circle == i, "y"], col = "black")
}
}
title(title, outer = TRUE, line = -1)
if (length(cord.X) != max(mat) & length(cord.X) != 1){
for (i in 1 : (max(mat)-length(cord.X))){
plot(1,1, type = "n", axes = FALSE, ann = FALSE)
}
}
if (legend)
legend("center",
legend = blocks,
title="Block",
col = unique(df$col),
pch = unique(df$pch),
cex = unique(df$cex),
bty = "n")
par(opar)
}
}
#-- End: graphics
#-- Start: 3d
if(style=="3d") {
open3d()
par3d(windowRect = c(500, 30, 1100, 630))
Sys.sleep(0.5)
if (!is.null(title)) {
mat = matrix(1:2, 2)
layout3d(mat, heights = c(1, 10), model = "inherit")
next3d()
text3d(0, 0, 0, title)
next3d()
}
par3d(userMatrix = rotationMatrix(pi/80, 1, -1/(100*pi), 0))
if (legend) {
legend3d(x="right",
legend = blocks,
col = unique(col),
pch = rep(16,length(unique(pch))),
pt.cex = unique(cex),
bty="n")
}
if (any(axes.box == "axes") || any(axes.box == "all"))
axes3d(c('x','y','z'), pos = c(0, 0, 0), nticks = 2, at = c(-1.2, 1.2),
tick = FALSE, labels = "")
for (i in 1 : length(var.names)){
if (var.names[i]) {
text3d(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
texts = df[c((ind.group[i] + 1) : ind.group[i + 1]), "names"],
color = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
cex = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"],
font = df[c((ind.group[i] + 1) : ind.group[i + 1]), "font"])
} else {
switch(unique(df[c((ind.group[i] + 1) : ind.group[i + 1]), "pch"]),
sphere = plot3d(x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"], type = "s",
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"], radius = cex/20, add = TRUE),
tetra = shapelist3d(tetrahedron3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/25),
cube = shapelist3d(cube3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/30),
octa = shapelist3d(octahedron3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/17),
icosa = shapelist3d(icosahedron3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/20),
dodeca = shapelist3d(dodecahedron3d(), x = df[c((ind.group[i] + 1) : ind.group[i + 1]), "x"],
y = df[c((ind.group[i] + 1) : ind.group[i + 1]), "y"],
z=df[c((ind.group[i] + 1) : ind.group[i + 1]), "z"],
col = df[c((ind.group[i] + 1) : ind.group[i + 1]), "col"],
size = df[c((ind.group[i] + 1) : ind.group[i + 1]), "cex"]/20))
}
}
par3d(cex = 0.8)
#-- draws axes --#
if (any(axes.box == "axes") || any(axes.box == "all")) {
if (any(label.axes.box == "axes") || any(label.axes.box == "both")) {
text3d(1.2, -0.05, 0, texts = X.label, cex = 0.8, color = "black")
text3d(0, 1.27, 0, texts = Y.label, cex = 0.8, color = "black")
text3d(0, -0.05, 1.2, texts = Z.label, cex = 0.8, color = "black")
}
X = c(1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09,
0.0, 0.0, 0.0, 0.0, 0.035, -0.035, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4), 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4),
0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.035, -0.035, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4))
Y = c(0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.035, -0.035, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4),
1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09,
0.0, 0.035, -0.035, 0.0, 0.0, 0.0, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4), 0.0, -0.035*sin(pi/4), 0.035*sin(pi/4))
Z = c(0.0, 0.035, -0.035, 0.0, 0.035, -0.035, 0.0, 0.0, 0.0, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4),
0.0, 0.035, -0.035, 0.0, 0.0, 0.0, 0.0, 0.035*sin(pi/4), -0.035*sin(pi/4), 0.0, -0.035*sin(pi/4), 0.035*sin(pi/4),
1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09, 1.2, 1.09, 1.09)
triangles3d(x = X, y = Y, z = Z, col = "black")
}
points3d(1.2, 0, 0, size = 0.1, alpha = 0)
points3d(0, 1.2, 0, size = 0.1, alpha = 0)
points3d(0, 0, 1.2, size = 0.1, alpha = 0)
points3d(-1.2, 0, 0, size = 0.1, alpha = 0)
points3d(0, -1.2, 0, size = 0.1, alpha = 0)
points3d(0, 0, -1.2, size = 0.1, alpha = 0)
#-- draws sphere --#
spheres3d(0, 0, 0, radius = rad.in, front = "fill", back = "fill", emission = gray(0.9), alpha = 0.4)
spheres3d(0, 0, 0, radius = rad.in, front = "line", back = "line", emission = gray(0.9))
#-- draws axes/box and add axes labels --#
if (any(axes.box == "box") || any(axes.box == "all")) {
axes3d(marklen = 25)
box3d()
if (any(label.axes.box == "box") || any(label.axes.box == "both")) {
mtext3d(X.label, "x-+", line = 1)
mtext3d(Y.label, "y-+", line = 1.5)
mtext3d(Z.label, "z+-", line = 1)
}
}
if (any(axes.box == "bbox") || any(axes.box == "all")) {
bbox3d(color = c("#333377", "black"), emission = gray(0.5),
specular = gray(0.1), shininess = 5, alpha = 0.8, marklen = 25)
if (any(label.axes.box == "box") || any(label.axes.box == "both")) {
mtext3d(X.label, "x-+", line = 1)
mtext3d(Y.label, "y-+", line = 1.5)
mtext3d(Z.label, "z+-", line = 1)
}
}
}
#-- End: graphics
if(plot){
return(invisible(df))}
else
return(df)
}
Try the mixOmics package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.