Nothing
R/sampleView.R
In RclusTool: Graphical Toolbox for Clustering and Classification of Data Frames
Defines functions
messageConsole
tkEmptyLine
makeTitle
tkrreplot.RclusTool
tkrplot.RclusTool
tk2draw.notetab
tk2add.notetab
tk2delete.notetab
ElbowPlot
abdPlot
abdPlotTabsGUI
abdPlotTabs
cor.mtest
analyzePlot
visualizeSampleClustering
plotDensity2D
plotSampleFeatures
plotProfileExtract
plotProfile
Documented in
abdPlot
abdPlotTabs
abdPlotTabsGUI
analyzePlot
cor.mtest
ElbowPlot
makeTitle
messageConsole
plotDensity2D
plotProfile
plotProfileExtract
plotSampleFeatures
tk2add.notetab
tk2delete.notetab
tk2draw.notetab
tkEmptyLine
tkrplot.RclusTool
tkrreplot.RclusTool
visualizeSampleClustering
# RclusTool: clustering of items in datasets
#
# Copyright 2013 Guillaume Wacquet, Pierre-Alexandre Hebert, Emilie Poisson-Caillault
#
#
# 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 3 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, see <http://www.gnu.org/licenses/>.
#' plotProfile plots the profile and the image (if available) of a particle
#' @title Profile and image plotting
#' @description Plot the profile and the image (if available) of a particle.
#' @param profiles matrix of profile data (signals in columns).
#' @param profiles.colors vector of colors corresponding to each signal in profile.
#' @param image character vector specifying the name (without path) + extension of the associated image (if available).
#' @param curve.names vector of character specifying the names of each signal in profile.
#' @param title character vector specifying the title of the plot.
#' @param sub character vector specifying the subtitle of the plot.
#' @param sub.color character vector specifying the color of the subtitle.
#' @param image.dir images directory.
#' @param charsize character size
#' @return None
#' @importFrom graphics layout plot rasterImage matplot legend
#' @importFrom jpeg readJPEG
#' @importFrom png readPNG
#' @importFrom rlang .data
#' @import reshape ggplot2
#' @seealso \code{\link{plotSampleFeatures}}, \code{\link{visualizeSampleClustering}}
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf1 <- tempfile()
#' write.table(dat, tf1, sep=",", dec=".")
#'
#' sig <- data.frame(ID=rep(1:150, each=30), SIGNAL=rep(dnorm(seq(-2,2,length=30)),150))
#' tf2 <- tempfile()
#' write.table(sig, tf2, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf1, file.profiles=tf2)
#'
#' plotProfile(x$profiles[[1]])
#'
#'
#' @keywords internal
#'
plotProfile <- function(profiles, profiles.colors=NULL, image=NULL, curve.names=NULL, title="Some observation", sub="", sub.color=NULL, image.dir=NULL, charsize=11){
p <- ggplot() + ggplot2::ggtitle(paste(title,sub))
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::theme(axis.text.x = element_text(size = charsize))
p <- p + ggplot2::theme(axis.text.y = element_text(size = charsize))
p <- p + ggplot2::theme(plot.title = element_text(size = charsize))
nc <- ncol(profiles)
if (!is.null(nc)) {
if (is.null(curve.names))
curve.names <- colnames(profiles)
profiles.df<-as.data.frame(profiles)
profiles.df$line<-1:nrow(profiles.df)
profiles.df <- reshape::melt(profiles.df, id.vars="line")
# Everything on the same plot
p <- ggplot2::ggplot(profiles.df, ggplot2::aes(x=.data$line,y=.data$value,col=.data$variable)) + ggplot2::labs(col="Profiles")
p <- p + ggplot2::ggtitle(paste(title,sub))
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::xlab("") + ggplot2::ylab("Value")
}
if (is.null(image))
image <- NA
if (is.null(image.dir))
image.dir <- ""
if (!is.na(image)) {
imgFile <- file.path(image.dir, image)
readImg <- jpeg::readJPEG
if (!grepl(".jpg", imgFile))
readImg <- png::readPNG
if (grepl(".jpg", imgFile) || grepl(".png", imgFile)) {
img <- readImg(imgFile, native = TRUE)
}
p <- p + ggplot2::annotation_custom(grid::rasterGrob(img,
width = unit(1,"npc"),
height = unit(1,"npc")),
-Inf, Inf, -Inf, Inf)
}
if (!is.null(nc)) {
if (is.null(profiles.colors)){
profiles.colors <- rep("black", length(curve.names))
}
p <- p + ggplot2::geom_line(size=0.9)
p <- p + ggplot2::scale_color_manual(values= profiles.colors[1:nc])
}
print(p)
}
#' plotProfileExtract plots the profile and the image (if available) of a particle
#' @title Profile and image plotting
#' @description Plot the profile and the image (if available) of a particle.
#' @param profiles matrix of profile data (signals in columns).
#' @param profiles.colors vector of colors corresponding to each signal in profile.
#' @param image character vector specifying the name (without path) + extension of the associated image (if available).
#' @param curve.names vector of character specifying the names of each signal in profile.
#' @param title character vector specifying the title of the plot.
#' @param sub character vector specifying the subtitle of the plot.
#' @param sub.color character vector specifying the color of the subtitle.
#' @param image.dir images directory.
#' @return None
#' @importFrom graphics layout plot rasterImage matplot legend
#' @importFrom jpeg readJPEG
#' @importFrom png readPNG
#' @seealso \code{\link{plotSampleFeatures}}, \code{\link{visualizeSampleClustering}}
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf1 <- tempfile()
#' write.table(dat, tf1, sep=",", dec=".")
#'
#' sig <- data.frame(ID=rep(1:150, each=30), SIGNAL=rep(dnorm(seq(-2,2,length=30)),150))
#' tf2 <- tempfile()
#' write.table(sig, tf2, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf1, file.profiles=tf2)
#'
#' plotProfileExtract(x$profiles[[1]])
#'
#'
#' @keywords internal
#'
plotProfileExtract <- function(profiles, profiles.colors=NULL, image=NULL, curve.names=NULL, title="Some observation", sub="", sub.color=NULL, image.dir=NULL){
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
nc <- ncol(profiles)
if (is.null(image))
image <- NA
if (is.null(image.dir))
image.dir <- ""
dimLayout <- as.numeric(!is.null(nc)) + as.numeric(!is.na(image))
graphics::layout(matrix(c(1,dimLayout), 1, 2, byrow = TRUE), widths=rep(1, dimLayout))
par(mar=c(6,3,2,.2)) #bottom large because of sub parameter
if (!is.null(nc)) {
if (is.null(curve.names))
curve.names <- colnames(profiles)
#correspondances of colors
if (!is.null(profiles.colors)) {
curve.colors <- sapply(curve.names, function (x) {col<-profiles.colors[x];
if (is.na(col)) 'black' else col})
} else {
curve.colors <- rep("black", length(curve.names))
}
if (is.null(sub.color))
sub.color <- "black"
#matplot(profiles, pch=1:nc, type="o", col=curve.colors, main=title, sub=sub, col.sub=sub.color, ylab="level", cex = 0.8)
graphics::matplot(profiles, pch=1:nc, type="o", col=curve.colors, main=title, sub=sub, ylab="level", cex = 0.8)
if (!is.null(curve.names))
graphics::legend("topright", legend=curve.names, col=curve.colors, pch=1:nc, cex=0.8)
}
par(mar=c(5,.2,5,.2))
if (!is.na(image)) {
imgFile <- file.path(image.dir, image)
readImg <- jpeg::readJPEG
if (!grepl(".jpg", imgFile))
readImg <- png::readPNG
if (grepl(".jpg", imgFile) || grepl(".png", imgFile)) {
img <- readImg(imgFile, native = TRUE)
dimg <- dim(img)
h <- dimg[1]
w <- dimg[2]
graphics::plot(c(0, w), c(0, h), type = "n", xlab = "", ylab = "", axes = FALSE)
graphics::rasterImage(img, 0, 0, w, h)
}
}
}
#' plotSampleFeatures plots 2D-features scatter-plot of all particles
#' @title 2D-features scatter-plot
#' @description Plot 2D-features scatter-plot of all particles. Grey color (label=0) is for data to cleaned or to remove in classification process.
#' @param data matrix or data.frame of raw data (points by line).
#' @param label vector of labels.
#' @param parH character vector specifying the name of the feature to use as x-axis.
#' @param parV character vector specifying the name of the feature to use as y-axis.
#' @param figure.title character vector specifying the title of the scatter-plot.
#' @param logscale character vector containing "x" if the x-axis is to be logarithmic, "y" if the y-axis is to be logarithmic and "xy" or "yx" if both axes are to be logarithmic.
#' @param cex numeric value specifying the size of the graphical labels.
#' @param point.param data.frame specifying the colors and the symbols to use for clusters display.
#' @param env.plot environment where to store graphical parameters used by function PlotScatter to select points.
#' @return None
#' @importFrom grDevices colors
#' @importFrom graphics title plot abline legend par
#' @seealso \code{\link{plotProfile}}, \code{\link{visualizeSampleClustering}}
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf1 <- tempfile()
#' write.table(dat, tf1, sep=",", dec=".")
#'
#' sig <- data.frame(ID=rep(1:150, each=30), SIGNAL=rep(dnorm(seq(-2,2,length=30)),150))
#' tf2 <- tempfile()
#' write.table(sig, tf2, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf1, file.profiles=tf2)
#'
#' res <- KmeansQuick(x$features$initial$x, K=3)
#' new.labels <- formatLabelSample(res$cluster, x)
#'
#' plotSampleFeatures(x$features$initial$x, label = new.labels, parH="x", parV="y")
#'
#'
#' @keywords internal
#'
plotSampleFeatures<- function(data, label, parH=NULL, parV=NULL, figure.title="Scatter plot",
logscale="", cex=.8, point.param=expand.grid(
col=c("grey","black","red","blue","green","cyan", "yellow","orange",
"rosybrown","palevioletred","darkblue","deeppink","blueviolet", 'darkgoldenrod1', 'chartreuse',
"darkorchid1", "deeppink", "coral", "darkolivegreen1","#66C2A5","#9DAE8C","#D49A73","#F08F6D",
"#C79693","#9E9DBA","#9F9BC9","#C193C6","#E28BC3","#D2A29F","#BABF77","#AAD852","#CBD844",
"#ECD836","#FAD53E","#F1CD64","#E7C689","#D7BF9C","#C5B9A7","#B3B3B3","#D53E4F","#E04F4A",
"#EB6046","#F47346","#F88B51","#FBA35C","#FDB869","#FDCA79","#FDDD88","#F6E68F","#EDEE93",
"#E2F398","#CDEA9D","#B7E2A1","#A0D8A4","#86CEA4","#6DC4A4","#58B2AB","#459DB4","#3288BD"),
pch=c(20, 0:18), stringsAsFactors = FALSE), env.plot = NULL){
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
if (is.null(parH)) {
parH <- colnames(data)[1]
}
if (is.null(parV)) {
parH <- colnames(data)[2]
}
#numeros des clusters dans l'ordre
vlabel <- levels(label)
#construction des donnees
x <- data[, c(parH, parV), drop=FALSE]
if (cex==0.8){
graphics::par(mar=c(3.9, 3.9, 1.5, 10.5), xpd=TRUE)
} else if (cex==0.7) {
graphics::par(mar=c(3.9, 3.9, 1.5, 8.1), xpd=TRUE)
} else if (cex==0.6) {
graphics::par(mar=c(3.9, 3.9, 1.5, 7.1), xpd=TRUE)
}
#plot
graphics::plot(x, type="p", col=point.param$col[unclass(label)], pch=point.param$pch[unclass(label)],
cex=cex, cex.lab=cex, cex.sub=cex, cex.axis=cex, log=logscale, ann=FALSE) #pch=1, cex=.8, yaxt = "n",xaxt = "n");
graphics::abline( h = 0, lty = 3, col = grDevices::colors()[ 440 ] )
graphics::abline( v = 0, lty = 3, col = grDevices::colors()[ 440 ] )
#titles+legendes
graphics::title(figure.title, xlab=parH, ylab=parV, cex.main=cex)
coord <- graphics::par("usr")
graphics::legend("topright", legend=vlabel, col=point.param$col[1:length(vlabel)],
pch=point.param$pch[1:length(vlabel)], cex=cex, pt.cex=cex, inset=c(-0.25,0), box.lty=0)
if (!is.null(env.plot))
{
env.plot$parPlotSampleFeatures <- par(no.readonly=TRUE)
}
}
#' plotDensity2D plots density of a variable by cluster
#' @title plot Variables Density
#' @description Plots density of a variable by cluster.
#' @param data density data.frame with x,y and Cluster indication.
#' @param parH character vector specifying the name of the feature to use as x-axis.
#' @param clustering.name character vector specifying the name of the clustering.
#' @param charsize character size
#' @param col vector of colors
#' @return None
#' @import ggplot2
#'
#' @examples
#'
#' dat <- rbind(matrix(rnorm(100, mean = 0, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2))
#' tf <- tempfile()
#' write.table(dat, tf, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf)
#' x <- computeUnSupervised(x, K=3, method.name="K-means")
#'
#' label<-x[["clustering"]][["K-means_preprocessed"]][["label"]]
#'
#' cluster.density <- clusterDensity(x, label, "preprocessed",features.to.keep='V1')
#' plotDensity2D(cluster.density, clustering.name='Test Kmeans', parH='V1')
#'
#'
#' @keywords internal
#'
plotDensity2D <- function(data, parH=NULL, clustering.name, charsize = 11,
col=c("grey","black","red","blue","green","cyan", "yellow","orange",
"rosybrown","palevioletred","darkblue","deeppink","blueviolet", 'darkgoldenrod1', 'chartreuse',
"darkorchid1", "deeppink", "coral", "darkolivegreen1","#66C2A5","#9DAE8C","#D49A73","#F08F6D",
"#C79693","#9E9DBA","#9F9BC9","#C193C6","#E28BC3","#D2A29F","#BABF77","#AAD852","#CBD844",
"#ECD836","#FAD53E","#F1CD64","#E7C689","#D7BF9C","#C5B9A7","#B3B3B3","#D53E4F","#E04F4A",
"#EB6046","#F47346","#F88B51","#FBA35C","#FDB869","#FDCA79","#FDDD88","#F6E68F","#EDEE93",
"#E2F398","#CDEA9D","#B7E2A1","#A0D8A4","#86CEA4","#6DC4A4","#58B2AB","#459DB4","#3288BD")){
tryCatch(
expr = {
p <- ggplot2::ggplot(data=data, ggplot2::aes(x=data$x, y=data$y, colour=data$Cluster, shape=data$Cluster)) + ggplot2::labs(col="Cluster")
p <- p + ggplot2::geom_line(size=1) + ggplot2::scale_color_manual(values=(col))
p <- p + ggplot2::xlab(parH) + ggplot2::ylab("Density")
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::ggtitle(paste('Variables density plot by', clustering.name, sep=" "))
p <- p + ggplot2::theme(axis.text.x = element_text(size = charsize))
p <- p + ggplot2::theme(axis.text.y = element_text(size = charsize))
p <- p + ggplot2::theme(plot.title = element_text(size=charsize))
print(p)
},
error = function(e){
message(e)
if (grepl('-monotype-arial',as.character(e))==TRUE){
message("Error :Please, Try to install gsfonts-x11")
}
}
)
}
#' visualizeSampleClustering opens an interactive figure with 2D scatter-plot of all particles with axis choice
#' @title Interactive figure with 2D scatter-plot
#' @description Open an interactive figure with 2D scatter-plot of all particles with axis choice. Grey color (label=0) is for data to cleaned or to remove in classification process.
#' @param data.sample list containing features, profiles and clustering results.
#' @param label vector of labels.
#' @param clustering.name character vector specifying the clustering method used to get labels.
#' @param cluster.summary data.frame containing the clusters summaries (as returned by 'clusterSummary').
#' @param RclusTool.env environment in which all global parameters, raw data and results are stored.
#' @param prototypes list containing vectors of prototypes indices.
#' @param profile.mode character vector specifying the plot mode of profiles. Must be 'none' (default), 'whole sample', 'cluster i' or 'constrained pairs'.
#' @param selection.mode character vector specifying the selection mode of profiles. Must be 'none' (default), 'prototypes' or 'pairs'.
#' @param compare.mode character vector specifying the mode of comparison between two clusterings results. Must be 'off' (default) or 'on'.
#' @param pairs list of constrained pairs (must-link and cannot-link).
#' @param features.mode character vector specifying the plot mode of features (projection in a specific space). Must be 'initial' (default), 'preprocessed', 'pca', 'pca_full' or 'spectral', or prefixed versions ('sampled', 'scaled') of those space names.
#' @param wait.close boolean: if FALSE (default), the following steps of the analysis calculations are computed even if the window is not closed.
#' @param fontsize size of font (default is 9)
#' @return prototypes in \code{selection.mode} = "prototypes" mode, pairs in \code{selection.mode} = "pairs" mode.
#' @seealso \code{\link{plotProfile}}, \code{\link{plotSampleFeatures}}
#' @importFrom graphics barplot boxplot axis points filled.contour par
#' @importFrom SearchTrees createTree knnLookup
#' @importFrom grDevices gray topo.colors
#' @importFrom MASS kde2d
#' @import tcltk tcltk2 tkrplot ggplot2
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf1 <- tempfile()
#' write.table(dat, tf1, sep=",", dec=".")
#'
#' sig <- data.frame(ID=rep(1:150, each=30), SIGNAL=rep(dnorm(seq(-2,2,length=30)),150))
#' tf2 <- tempfile()
#' write.table(sig, tf2, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf1, file.profiles=tf2)
#'
#' res <- KmeansQuick(x$features$initial$x, K=3)
#' new.labels <- formatLabelSample(res$cluster, x)
#'
#' visualizeSampleClustering(x, label = new.labels, clustering.name="K-means",
#' profile.mode="whole sample")
#'
#' @export
#'
visualizeSampleClustering<- function(data.sample, label=NULL, clustering.name="proposed clustering",
cluster.summary=NULL, RclusTool.env=initParameters(),
prototypes=NULL, profile.mode="none",
selection.mode="none", compare.mode="off",
pairs=NULL, features.mode="initial",
wait.close=FALSE, fontsize=9){
#----------------------------------------------------------------------------------------
# Variables of the function
#----------------------------------------------------------------------------------------
visu.env <- new.env()
visu.env$plot.mode <- "scatter-plot"
visu.env$plotSampleFunction <- function(compare){} #function called by plotSample
visu.env$parH <- NULL
visu.env$parV <- NULL
visu.env$parPlotSampleFeatures <- NULL
visu.env$previous.clustering.name <- NULL
visu.env$label <- label
visu.env$cluster.summary <- cluster.summary
visu.env$clustering.name <- clustering.name
visu.env$data.sample <- data.sample
visu.env$prototypes <- NULL
visu.env$profile.mode <- profile.mode
visu.env$slider.values <- NULL #ids of subset of particles dealt with (may be a cluster, or prototypes)
visu.env$pts.search.tree <- NULL #search tree to locate mouse-selected points in scatter plot
visu.env$profile.id <- c(
sel=NA, #profile selected (in the top) id relative to described particles (by features$x)
mem=NA, #profile memorized (in the bottom)
fig=NA) #profile plotted (not always the one selected)
visu.env$mem.mode <- FALSE
visu.env$pairs.values <- NULL
visu.env$pairs.constraints <- NULL
visu.env$plot.height <- c() #graphic parameter : height of plot part (left)
visu.env$features.mode <- features.mode
visu.env$features <- NULL
visu.env$tcl.proto.label <- tclVar("")
visu.env$box.pixel <- NULL #plot bounding box in unit pixel
visu.env$compare.mode <- compare.mode
visu.env$summary.feat.select <- NULL
visu.env$summary.fun.select <- NULL
visu.env$summary.feature <- NULL # = couple feat + fun
visu.env$onScatterPlotMove <- function(x,y){}
visu.env$ProfileModeNumber <- 1
visu.env$tk.font <- tkfont.create(size = fontsize, family = "Arial", weight = "bold")
if (fontsize>=11){
visu.env$cex=0.8
} else if (fontsize>=9) {
visu.env$cex=0.7
} else {
visu.env$cex=0.6
}
if (!is.null(visu.env$label))
{
# case : new label to add
visu.env$label <- formatLabelSample(visu.env$label[visu.env$data.sample$id.clean], visu.env$data.sample, new.labels=FALSE, noise.cluster=RclusTool.env$param$preprocess$noise.cluster)
if (is.null(visu.env$cluster.summary))
visu.env$cluster.summary <- clusterSummary(visu.env$data.sample, visu.env$label, summary.functions=RclusTool.env$param$analysis$summary.functions)
visu.env$data.sample$clustering <- addClustering(clustering=visu.env$data.sample$clustering, new.clustering.name=visu.env$clustering.name,
new.cluster.summary=visu.env$cluster.summary, new.label=visu.env$label)
}
if (!is.null(visu.env$data.sample$clustering[[visu.env$clustering.name]]))
{
# case: data.sample contains the clustering named
visu.env$label <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$label
visu.env$cluster.summary <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary
} else {
if (is.null(visu.env$label)) {
# case: clustering named doesn't exist and no clustering proposed
visu.env$clustering.name <- "no-clustering"
visu.env$label <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$label
visu.env$cluster.summary <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary
}
}
visu.env$prototypes <- sapply(visu.env$data.sample$clustering, function(x) x$prototypes)
if (is.null(visu.env$prototypes[[visu.env$clustering.name]]))
{
if (!is.null(visu.env$data.sample$clustering[[visu.env$clustering.name]]$prototypes)) {
visu.env$prototypes[[visu.env$clustering.name]] <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$prototypes
} else {
visu.env$prototypes[[visu.env$clustering.name]] <- c()
}
visu.env$prototypes[[visu.env$clustering.name]] <- as.character(visu.env$label[names(visu.env$prototypes[[visu.env$clustering.name]])])
}
###MODIF
# prototypes$id <- visu.env$data.sample$id.abs.inv[prototypes$id.abs] #id: in sample not cleaned
# prototypes$label <- as.character(visu.env$label[prototypes$id])
# prototypes$id.abs.inv <- rep(NA, max(visu.env$data.sample$id.abs))
# prototypes$id.abs.inv[prototypes$id.abs] <- 1:length(prototypes$label) #id: in prototypes
#
if (length(grep("prototype", visu.env$profile.mode, ignore.case=TRUE))&&(!length(visu.env$prototypes)))
visu.env$profile.mode <- "none"
if (is.null(pairs)) {
visu.env$pairs.values <- list() #list of pairs (vector of 2 particle ids)
visu.env$pairs.constraints <- c() #how pair are constrained (+1 for ML, -1 for CNL)
} else {
visu.env$pairs.values <- c(pairs$ML, pairs$CNL)
visu.env$pairs.constraints <- c(rep(1,length(pairs$ML)), rep(-1, length(pairs$CNL)))
}
color.select <- c(grDevices::gray(0.25),grDevices::gray(0.90)) #color to plot selected particles points
if (!(visu.env$features.mode %in% names(visu.env$data.sample$features)))
visu.env$features.mode <- names(visu.env$data.sample$features)[1]
visu.env$features <- visu.env$data.sample$features[[visu.env$features.mode]]
visu.env$features$x <- visu.env$features$x[sapply(visu.env$features$x, is.numeric)]
signals <- visu.env$data.sample$profiles
images <- visu.env$data.sample$images
tcl.plot.mode <- tclVar(visu.env$plot.mode)
tcl.clustering.mode <- tclVar(visu.env$clustering.name)
tcl.features.mode <- tclVar(visu.env$features.mode)
tcl.profile.mode <- tclVar(visu.env$profile.mode) #"none", "whole sample", ou "cluster 'i'"
tcl.compare.mode <- tclVar(visu.env$compare.mode)
tcl.slider.big <- tclVar("0")
tcl.slider.tune <- tclVar("1")
slider.max <- 300 #maximal incrementations of slider.tune
#if (is.null(visu.env$cluster.summary))
#visu.env$cluster.summary <- clusterSummary(visu.env$data.sample, visu.env$label, summary.functions=RclusTool.env$param$analysis$summary.functions)
initClusterSummaryFeature <- function()
{
old.feature <- visu.env$summary.feature
summary.feats <- extractFeaturesFromSummary(visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary)
if (!length(summary.feats$simple))
stop("sampleView, visualizeSampleClustering: no simple features in the summary")
cluster.summary.simple.features <- paste("Result", summary.feats$simple.feats)
if (is.null(old.feature)|| !(old.feature %in% cluster.summary.simple.features))
visu.env$summary.feature <- cluster.summary.simple.features[1]
}
initClusterSummaryFeature()
cluster.summary.init <- visu.env$cluster.summary
#----------------------------------------------------------------------------------------
# functions to deal with ids of selected particles
#----------------------------------------------------------------------------------------
# not for profile.mode=="constrained pairs"
setProfileId <- function(names, value){
isna <- is.na(value)||!is.element(value, visu.env$slider.values)#is.na(visu.env$features$ids.inv[value])
if (isna)
value <- visu.env$slider.values[1]
for (name in names) {
visu.env$profile.id[name] <- value
}
if (is.element("sel", names))
setSlidersId(value, value=TRUE)
if ((is.element("mem", names))&&isna)
setMemMode(FALSE)
updateProfilesPlot(names)
}
# pair : a pair from slider.value
setProfileIdsPair <- function(pair){
names <- c("fig", "mem", "sel")
pair <- unlist(pair)
if (any(is.na(visu.env$features$x[pair,1]))) #(any(is.na(features$id.abs.inv[pair]))) ????
pair <- unlist(visu.env$slider.values[1])
for (name in names) {
val <- switch(name, fig=pair[1], sel=pair[1], mem=pair[2])
visu.env$profile.id[name] <- val
}
# if (is.element("sel", names))
# setSlidersId(value, value=TRUE)
updateProfilesPlot(names)
}
updateProfileId <- function(names=c("fig","mem","sel")){
for (name in names) {
setProfileId(name, visu.env$profile.id[name])#test
}
}
#----------------------------------------------------------------------------------------
# plot functions of the sample (left area)
#----------------------------------------------------------------------------------------
plotSample <- function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg="white")
visu.env$plotSampleFunction(compare=FALSE)
}
plotSampleCompare <- function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg="white")
visu.env$plotSampleFunction(compare=TRUE)
}
plotScatter <- function(compare=FALSE){
label <- visu.env$features$label
clustering.name <- visu.env$clustering.name
if (compare) {
clustering.name <- visu.env$previous.clustering.name
label <- visu.env$data.sample$clustering[[clustering.name]]$label[rownames(visu.env$features$x)]
}
x <- visu.env$features$x.2D.logscale
logscale <- visu.env$features$logscale.2D
title <- paste(visu.env$plot.mode, "clustered by", clustering.name)
plotSampleFeatures(x, label, parH=visu.env$parH, parV=visu.env$parV, figure.title=title,
logscale=logscale, cex=visu.env$cex, point.param=RclusTool.env$param$visu$point.style, env.plot=visu.env)
if (is.null(visu.env$parPlotSampleFeatures))
return()
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
par(visu.env$parPlotSampleFeatures)
#ids <- visu.env$features$id.abs.inv[c(visu.env$profile.id$sel, visu.env$profile.id$mem)]
#names(ids) <- c("sel", "mem")
ids <- visu.env$profile.id[c("sel", "mem")]
# add links
if (visu.env$profile.mode=="constrained pairs") {
selected.pair.id <- getSlidersValue(value=FALSE)
for (i in 1:length(visu.env$slider.values)) {
if (i==selected.pair.id)
next
pair <- visu.env$pairs.values[[i]]
w <- pair #features$id.abs.inv[pair]
#if (any(is.na(w)))
if (any(is.na(x[w,])))
next
if (visu.env$pairs.constraints[i]==1) {
graphics::points(x[w,], type="l", col="darkgreen", lwd=2)
}
if (visu.env$pairs.constraints[i]==-1) {
graphics::points(x[w,], type="l", col="darkred", lwd=2)
}
}
if (!any(is.na(ids))) {###A verifier
if (visu.env$pairs.constraints[selected.pair.id]==1) {
graphics::points(x[ids,], type="l", col="darkgreen", lwd=4)
}
if (visu.env$pairs.constraints[selected.pair.id]==-1) {
graphics::points(x[ids,], type="l", col="darkred", lwd=4)
}
}
}
# add point whose profile is plotted
#colored cross + circle + point on selected point(s)
if ((visu.env$profile.mode!="none") && (!(is.na(ids["sel"]))))
graphics::points(x[rep(ids["sel"],3),,drop=FALSE],
pch=c("+", "O", RclusTool.env$param$visu$point.style$pch[unclass(label[ids["sel"]])]),
cex=c(2, 2, RclusTool.env$param$visu$cex),
col=c(color.select[1:2], RclusTool.env$param$visu$point.style$col[unclass(label[ids["sel"]])]))
if ((visu.env$mem.mode) && (!(is.na(ids["mem"]))))
graphics::points(x[rep(ids["mem"],3),,drop=FALSE],
pch=c("+", "O", RclusTool.env$param$visu$point.style$pch[unclass(label[ids["mem"]])]),
cex=c(2, 2, RclusTool.env$param$visu$cex),
col=c(color.select[1:2], RclusTool.env$param$visu$point.style$col[unclass(label[ids["mem"]])]))
parPlotSize <- par("plt")
width <- as.numeric(tclvalue(tkwinfo("reqwidth", tk.plot.fig)))
height <- as.numeric(tclvalue(tkwinfo("reqheight", tk.plot.fig)))
usrCoords <- par("usr")
width <- as.numeric(tclvalue(tkwinfo("reqwidth", tk.plot.fig)))
xMin <- parPlotSize[1] * width
xMax <- parPlotSize[2] * width
yMin <- parPlotSize[3] * height
yMax <- parPlotSize[4] * height
rangeX <- usrCoords[2] - usrCoords[1]
rangeY <- usrCoords[4] - usrCoords[3]
visu.env$plot.height <- height
# A VERIFIER
visu.env$features$x.2D.pixel <- cbind((visu.env$features$x.2D[,1]-usrCoords[1])*(xMax-xMin)/rangeX + xMin,
(visu.env$features$x.2D[,2]-usrCoords[3])*(yMax-yMin)/rangeY + yMin )
rownames(visu.env$features$x.2D.pixel) <- rownames(visu.env$features$x.2D)
visu.env$box.pixel <- c(xMin, xMax, yMin, yMax)
visu.env$usrCoords <- usrCoords
# if new plot, then search tree is rebuilt
if (is.null(visu.env$pts.search.tree))
buildPtsSearchTree()
}
plotDensity2Dcall <- function(compare=FALSE){
if (!compare) {
label <- visu.env$label
clustering.name <- visu.env$clustering.name
} else {
clustering.name <- visu.env$previous.clustering.name
label <- visu.env$data.sample$clustering[[clustering.name]]$label
}
if (is.null(visu.env$parH)) {
visu.env$parH <- colnames(data.sample$features[[visu.env$features.mode]]$x)[1]
}
cluster.density <- clusterDensity(data.sample, label, visu.env$features.mode, features.to.keep=visu.env$parH)
plotDensity2D(cluster.density,parH=visu.env$parH, clustering.name=clustering.name, col= RclusTool.env$param$visu$palette.colors)
}
plotDensity1D <- function(compare=FALSE){
compare <- NULL
x <- visu.env$features$x.2D
xtick <- pretty(x[,1])
ytick <- pretty(x[,2])
logscale <- visu.env$features$logscale.2D
labx <- xtick
laby <- ytick
if (length(grep("x",logscale)))
labx <- 10^xtick
if (length(grep("y",logscale)))
laby <- 10^ytick
densite <- MASS::kde2d(x[,1], x[,2], n=100, h=.1)
densite$z <- log10( removeZeros(densite$z, threshold=10^-6, positive=TRUE) ) #echelle log...
graphics::filled.contour(densite, color = grDevices::topo.colors,
plot.axes = { graphics::axis(1, at=xtick, labels=labx);
graphics::axis(2, at=ytick, labels=laby) })
# points(x)
graphics::title(xlab=colnames(visu.env$features$x.2D)[1]) #paste(visu.env$parH[1], visu.env$parH[2], sep=" - "))
graphics::title(ylab=colnames(visu.env$features$x.2D)[2]) #paste(visu.env$parV[1], visu.env$parV[2], sep=" - "))
graphics::title(paste(visu.env$plot.mode, "(log)"), cex.main=visu.env$cex)
}
plotSummary <- function(compare=FALSE){
if (!compare) {
label <- visu.env$label
clustering.name <- visu.env$clustering.name
} else {
clustering.name <- visu.env$previous.clustering.name
label <- visu.env$data.sample$clustering[[clustering.name]]$label
}
cluster.summary <- visu.env$data.sample$clustering[[clustering.name]]$summary
title <- paste(visu.env$plot.mode, "clustered by", clustering.name)
feature.name.summary <- visu.env$summary.feature
m <- match(rownames(cluster.summary), levels(label))
col <- RclusTool.env$param$visu$point.style$col[m]
if (grepl("Result", feature.name.summary)) {
feature.name.summary <- sub("Result ", "", feature.name.summary)
cluster.factor <- factor(rownames(cluster.summary), levels = rownames(cluster.summary))
df=data.frame(values=cluster.summary[, feature.name.summary],cluster=cluster.factor)
p <- ggplot2::ggplot(data=df,aes(y=values,x=df$cluster,fill=df$cluster)) + geom_bar(stat="identity")
p <- p + ggplot2::xlab("") + ggplot2::ylab(feature.name.summary)
p <- p + ggplot2::ggtitle(title)
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::theme(axis.text.x = element_text(angle = 90, size=11))
p <- p + ggplot2::scale_fill_manual(values=col, drop=FALSE)
p <- p + ggplot2::theme(legend.position='none')
p <- p + ggplot2::theme(axis.text.x = element_text(size = RclusTool.env$param$visu$size))
p <- p + ggplot2::theme(axis.text.y = element_text(size = RclusTool.env$param$visu$size))
p <- p + ggplot2::theme(plot.title = element_text(size = RclusTool.env$param$visu$size))
print(p)
} else {
graphics::boxplot(visu.env$data.sample$features[[visu.env$features.mode]]$x[visu.env$data.sample$id.clean,feature.name.summary]~
label[visu.env$data.sample$id.clean],
names=levels(label),
las=3, col=RclusTool.env$param$visu$point.style$col, border=RclusTool.env$param$visu$point.style$col, outline = FALSE,
main=title,
ylab=feature.name.summary)
}
}
# function linked to tk.plot.frame
OnPlotSample <- function() {
tkrreplot.RclusTool(tk.plot.fig)
if (visu.env$compare.mode=="on"){
tkrreplot.RclusTool(tk.plot.compare.fig)
}
}
#----------------------------------------------------------------------------------------
# functions to deal with interactivity in Plot part (left)
#----------------------------------------------------------------------------------------
OnLeavePlot <- function() {
if (is.element(visu.env$profile.mode, c("none", "constrained pairs")))
return()
if (visu.env$profile.id["sel"] != visu.env$profile.id["fig"])
setProfileId("fig", visu.env$profile.id["sel"])
}
OnMouseMove <- function(x, y) {
if (is.element(visu.env$profile.mode, c("none", "constrained pairs")))
return()
if (is.null(visu.env$pts.search.tree))
return()
xClick <- as.numeric(x)+0.5
yClick <- as.numeric(y)-0.5
yClick <- visu.env$plot.height - yClick
if ( (xClick<visu.env$box.pixel[1])||(xClick>visu.env$box.pixel[2])||
(yClick<visu.env$box.pixel[3])||(yClick>visu.env$box.pixel[4]) ) {
OnLeavePlot()
return()
}
# coords <- 10^c(usrCoords[1]+(xClick-xMin)*rangeX/(xMax-xMin),
# usrCoords[3]+(yClick-yMin)*rangeY/(yMax-yMin))
if (!is.null(visu.env$pts.search.tree)) {
w <- as.character(visu.env$slider.values[SearchTrees::knnLookup(visu.env$pts.search.tree, xClick, yClick, k=1)[1]])
#w <- as.character(class::knn(visu.env$features$x.2D.pixel[visu.env$slider.values,,drop=FALSE],
# c(xClick, yClick), visu.env$slider.values)) #A VERIFIER !!
setProfileId("fig", w)
}
}
OnMovePlotFun <- function(x,y)
{
visu.env$onScatterPlotMove(x,y)
}
OnMouseClick <- function(x, y) {
if (is.element(visu.env$profile.mode, c("none", "constrained pairs")))
return()
OnMouseMove(x, y)
setProfileId("sel", visu.env$profile.id["fig"])
OnPlotSample()
}
#----------------------------------------------------------------------------------------
# plot functions of the profile(s) (right area)
#----------------------------------------------------------------------------------------
OnPlotProfile <- function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg="white")
if (is.na(visu.env$profile.id["fig"]))
return()
id <- visu.env$profile.id["fig"]
cluster <- NA
if ( (selection.mode=="prototypes") && length(visu.env$prototypes[[visu.env$clustering.name]])){
cluster <- visu.env$prototypes[[visu.env$clustering.name]][id]
}
if (is.na(cluster))
cluster <- visu.env$features$label[id]
if (is.null(visu.env$data.sample$config$signalColor)){
signalColor <- RclusTool.env$param$visu$palette.colors
} else {
signalColor <- visu.env$data.sample$config$signalColor
}
if (is.null(visu.env$data.sample$profiles)){
visu.env$ProfileModeNumber <- 2
}
title.color <- RclusTool.env$param$visu$palette.colors[unclass(cluster)]
if (visu.env$ProfileModeNumber == 1){
plotProfile(visu.env$data.sample$profiles[[id]], profiles.colors=signalColor,
NULL, title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=NULL ,charsize=fontsize)
} else if (visu.env$ProfileModeNumber == 2){
plotProfile(NULL, profiles.colors=signalColor,
visu.env$data.sample$images[id], title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=visu.env$data.sample$files$images, charsize=fontsize)
} else {
plotProfile(visu.env$data.sample$profiles[[id]], profiles.colors=signalColor,
visu.env$data.sample$images[id], title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=visu.env$data.sample$files$images, charsize=fontsize)
}
tkpack(tk.profile.fig, fill="x")
}
OnPlotProfile2 <- function(){
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg="white")
if (is.na(visu.env$profile.id["mem"]))
return()
id <- visu.env$profile.id["mem"]
cluster <- NA
if ( (selection.mode=="prototypes") && length(visu.env$prototypes[[visu.env$clustering.name]])){
cluster <- visu.env$prototypes[[visu.env$clustering.name]][id]
}
if (is.na(cluster))
cluster <- visu.env$features$label[id]
if (is.null(visu.env$data.sample$config$signalColor)){
signalColor <- RclusTool.env$param$visu$palette.colors
} else {
signalColor <- visu.env$data.sample$config$signalColor
}
if (is.null(visu.env$data.sample$profiles)){
visu.env$ProfileModeNumber <- 2
}
if (visu.env$mem.mode)
{
title.color <- RclusTool.env$param$visu$palette.colors[unclass(cluster)] #[unclass(label[id])] ??
if (visu.env$ProfileModeNumber == 1){
plotProfile(visu.env$data.sample$profiles[[id]], profiles.colors=signalColor,
NULL, title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=NULL , charsize=fontsize)
} else if (visu.env$ProfileModeNumber == 2){
plotProfile(NULL, profiles.colors=signalColor,
visu.env$data.sample$images[id], title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=visu.env$data.sample$files$images ,charsize=fontsize)
} else {
plotProfile(visu.env$data.sample$profiles[[id]], profiles.colors=signalColor,
visu.env$data.sample$images[id], title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=visu.env$data.sample$files$images, charsize=fontsize)
}
tkpack(tk.profile.mem, fill="x")
} else
tkpack.forget(tk.profile.mem)
}
#----------------------------------------------------------------------------------------
# Menu functions
#----------------------------------------------------------------------------------------
OnModifPlotMode <- function() {
plot.mode.old <- visu.env$plot.mode
visu.env$plot.mode <- tclvalue(tcl.plot.mode)
visu.env$plotSampleFunction <- switch(visu.env$plot.mode,
"scatter-plot"=plotScatter,
"density-plot"=plotDensity1D,
"variables density by cluster"=plotDensity2Dcall,
"clusters summary"={
if (!is.null(visu.env$cluster.summary)){
plotSummary
} else {
visu.env$plot.mode <- plot.mode.old
tclvalue(tcl.plot.mode) <- visu.env$plot.mode
visu.env$plotSampleFunction
}
}
)
visu.env$onScatterPlotMove <- function(x,y){}
if (visu.env$plot.mode == "scatter-plot")
visu.env$onScatterPlotMove <- OnMouseMove
visibilityProfile() #hides/shows Profiles frame according to "cluster summary" mode or not
OnPlotSample()
}
OnModifFeaturesMode <- function() {
visu.env$features.mode <- tclvalue(tcl.features.mode)
tkdelete(tk.axis.menu, 0, "end")
visu.env$features <- visu.env$data.sample$features[[visu.env$features.mode]]
visu.env$features$x <- as.data.frame(visu.env$features$x)
if (visu.env$features.mode=="initial")
visu.env$features$x <- visu.env$features$x[sapply(visu.env$features$x,is.numeric)]
visu.env$features$label <- visu.env$label[rownames(visu.env$features$x)]
initAxis()
buildMenuInitialFeatures()
OnModifProfileMode()
}
# Transform parameters button
OnModifAxisH <- function() {OnModifAxisHV(Horizontal=TRUE)}
OnModifAxisV <- function() {OnModifAxisHV(Horizontal=FALSE)}
OnModifAxisHV <- function(Horizontal) {
feat.names <- colnames(visu.env$features$x)
if (!length(feat.names))
return()
if (Horizontal) {
axis.name <- "Horizontal"
feat.select <- visu.env$parH
} else {
axis.name <- "Vertical"
feat.select <- visu.env$parV
}
# Create new window for the parameter transformation
onmodiftt <- tktoplevel()
tktitle(onmodiftt) <- paste("Select", axis.name, "axis")
#Search the selected parameter
tkgrid(tk2label(onmodiftt, text = " "), row = 1, sticky = "w")
# First listbox with all parameters
feat.list <- tk2listbox(onmodiftt, selectmode = "single", activestyle = "dotbox",
height = 10, width = 27, autoscroll = "none", background = "white")
tkgrid(feat.list, row = 2, column = 0, rowspan = 4, sticky = "w")
# Close selection window operation
onClose <- function() {
tkdestroy(onmodiftt)
}
butClose <- tk2button(onmodiftt, text = "Close", width = -6, command = onClose)
tkgrid(butClose, row = 5, column=1, columnspan = 2)
for (feat in feat.names) {
tkinsert(feat.list, "end", feat)
}
OnFeatSelectH <- function()
{
visu.env$parH <- feat.names[as.numeric(tkcurselection(feat.list)) + 1]
modifAxisUpdate()
OnPlotSample()
buildMenuInitialFeatures()
}
OnFeatSelectV <- function()
{
visu.env$parV <- feat.names[as.numeric(tkcurselection(feat.list)) + 1]
modifAxisUpdate()
OnPlotSample()
buildMenuInitialFeatures()
}
# Initialize selection in the two listboxes
tkselection.set(feat.list, which(feat.names==feat.select)-1)
if (Horizontal) {
tkbind(feat.list, "<ButtonRelease-1>", OnFeatSelectH)
} else {
tkbind(feat.list, "<ButtonRelease-1>", OnFeatSelectV)
}
}
OnSimpleFeatSummary <- function(feat.name) {
tclvalue(tcl.plot.mode) <- "clusters summary"
visu.env$summary.feature <- paste("Result", feat.name)
OnModifPlotMode()
}
OnFeatFunSummary <- function() {
tclvalue(tcl.plot.mode) <- "clusters summary"
summary.names <- extractFeaturesFromSummary(visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary)
summary.names1 <- summary.names$feats
summary.names2 <- summary.names$funs
if (!length(summary.names1))
return()
if (!is.null(visu.env$summary.feat.select) && !is.null(visu.env$summary.fun.select)) {
summary.select1 <- visu.env$summary.feat.select
summary.select2 <- visu.env$summary.fun.select
} else {
summary.select1 <- summary.names1[1]
summary.select2 <- summary.names2[1]
}
# Create new window for the parameter transformation
onmodifcl <- tktoplevel()
tktitle(onmodifcl) <- paste("Select Cluster Summary")
#Search the selected parameter
tkgrid(tk2label(onmodifcl, text = " "), row = 1, sticky = "w")
# First listbox with all parameters
tkgrid(tk2label(onmodifcl, text = "Select the feature", justify = "left"),
row = 0, column = 0, sticky = "w")
summary.list1 <- tk2listbox(onmodifcl, selectmode = "single", activestyle = "dotbox",
height = 10, width = 27, autoscroll = "none", background = "white")
tkgrid(summary.list1, row = 1, column = 0, rowspan = 4, sticky = "w")
# Second listbox with all parameters
tkgrid(tk2label(onmodifcl, text = "Select the parameter", justify = "left"),
row = 0, column = 1, sticky = "w")
summary.list2 <- tk2listbox(onmodifcl, selectmode = "single", activestyle = "dotbox",
height = 10, width = 27, autoscroll = "none", background = "white")
tkgrid(summary.list2, row = 1, column = 1, rowspan = 4, sticky = "w")
# Close selection window operation
onClose <- function() {
tkdestroy(onmodifcl)
}
butClose <- tk2button(onmodifcl, text = "Close", width = -6, command = onClose)
tkgrid(butClose, row = 8, column=1, columnspan = 2)
for (summary1 in summary.names1) {
tkinsert(summary.list1, "end", summary1)
}
for (summary2 in summary.names2) {
tkinsert(summary.list2, "end", summary2)
}
onSummarySelect <- function()
{
visu.env$summary.feat.select <- summary.names1[as.numeric(tkcurselection(summary.list1)) + 1]
visu.env$summary.fun.select <- summary.names2[as.numeric(tkcurselection(summary.list2)) + 1]
value1 <- paste("Result", visu.env$summary.feat.select)
visu.env$summary.feature <- paste(value1, visu.env$summary.fun.select, sep="...")
OnModifPlotMode()
}
# Initialize selection in the two listboxes
tkselection.set(summary.list1, which(summary.names1==summary.select1)-1)
tkselection.set(summary.list2, which(summary.names2==summary.select2)-1)
tkbind(summary.list1, "<ButtonRelease-1>", onSummarySelect)
tkbind(summary.list2, "<ButtonRelease-1>", onSummarySelect)
}
modifAxisUpdate <- function() {
visu.env$features$x.2D <- visu.env$features$x[, c(visu.env$parH, visu.env$parV), drop=FALSE]
visu.env$features$x.2D.logscale <- visu.env$features$x.2D #representation for plot functions with log scale
logscale <- ""
if (visu.env$features$logscale[visu.env$parH]) {
logscale <- "x"
visu.env$features$x.2D.logscale[,1] <- 10^visu.env$features$x.2D[,1]
}
if (visu.env$features$logscale[visu.env$parV]) {
logscale <- paste(logscale, "y", sep="")
visu.env$features$x.2D.logscale[,2] <- 10^visu.env$features$x.2D[,2]
}
visu.env$features$logscale.2D <- logscale
# force rebuilding of the search tree
visu.env$pts.search.tree <- NULL
}
#without plotSample
initAxis <- function() {
pref.features <- NULL
#if (visu.env$features.mode == "initial")
# pref.features must be in colnames(features$x)!
# (if preprocessed data, with "log" suffix...)
# pref.features <- colnames(features$x)[grep(paste(visu.env$data.sample$config$defaultFeat, collapse = "|"), colnames(features$x))] #regular expression
pref.features <- intersect(visu.env$data.sample$config$defaultFeat, colnames(visu.env$features$x))
if (!is.null(pref.features) & (length(pref.features)>=2))
names(pref.features)[1:2] <- c("parH","parV")
#pref.features <- visu.env$data.sample$config$defaultFeat
if ( is.null(pref.features) || (length(pref.features)<2)
|| !any(colnames(visu.env$features$x)==pref.features["parH"])
|| !any(colnames(visu.env$features$x)==pref.features["parV"]) )
pref.features <- colnames(visu.env$features$x)[1:2]
visu.env$parH <- pref.features[1]
visu.env$parV <- pref.features[2]
modifAxisUpdate()
}
visibilityProfile <- function()
{
# hide profiles
if (visu.env$plot.mode != "scatter-plot")
{
tkpack.forget(tk.profile.frame)
return()
}
if (visu.env$profile.mode=="none") {
tkpack.forget(tk.profile.frame)
return()
}
tkpack(tk.profile.frame, side="left")
}
OnModifProfileMode <- function() {
new.mode <- tclvalue(tcl.profile.mode)
tkpack.forget(tk.profile.frame)
# if new mode not possible
if (!length(visu.env$prototypes) && ((new.mode=="prototypes"))){
tclvalue(tcl.profile.mode) <- visu.env$profile.mode
return()
}
if (!length(visu.env$pairs.values) && ((new.mode=="constrained pairs"))){
tclvalue(tcl.profile.mode) <- visu.env$profile.mode
return()
}
visu.env$profile.mode <- new.mode
# select particles able to be selected -> visu.env$slider.values
switch(visu.env$profile.mode,
"none"=c(),
"whole sample"=sortCharAsNum(rownames(visu.env$features$x)),
"items with signal(s)"=sortCharAsNum(rownames(signals)),
"items with image(s)"=sortCharAsNum(names(images)),
"prototypes"= names(visu.env$prototypes[[visu.env$clustering.name]][order(visu.env$prototypes[[visu.env$clustering.name]])]),
"constrained pairs"=visu.env$pairs.values,
{ #default
cluster.num <- tclvalue(tcl.profile.mode)
sortCharAsNum(rownames(visu.env$features$x)[visu.env$features$label==cluster.num])
}
) -> values
# if no particles can be selected : go back
if (!length(values)){
visu.env$profile.mode <- "none"
tclvalue(tcl.profile.mode) <- visu.env$profile.mode
OnPlotSample()
return()
}
configureSliders(values) #settings BEFORE positioning !
buildPtsSearchTree()
if (visu.env$profile.mode=="constrained pairs") {
setMemMode(TRUE)
OnSliderMove()
} else{
updateProfileId()
}
if (visu.env$profile.mode=="none")
setMemMode(FALSE)
OnPlotSample()
tkpack(tk.profile.frame, side="left")
}
#----------------------------------------------------------------------------------------
# Slider functions
#----------------------------------------------------------------------------------------
setSlidersId <- function(id, value=FALSE) {
if (value)
id <- match(id, visu.env$slider.values)
slider.tune.max <- min(slider.max, length(visu.env$slider.values))
val.big <- floor((id-1)/slider.tune.max)*slider.tune.max
val.tune <- id - val.big
tclvalue(tcl.slider.big) <- as.integer(val.big)
tclvalue(tcl.slider.tune) <- as.integer(val.tune)
}
getSlidersValue <- function(value=TRUE) {
if (tclvalue(tcl.slider.tune)=="0")
tclvalue(tcl.slider.tune) <- 1
id <- as.integer(tclvalue(tcl.slider.big)) + as.integer(tclvalue(tcl.slider.tune))
if (id > length(visu.env$slider.values)) {
tclvalue(tcl.slider.tune) <- length(visu.env$slider.values) - as.integer(tclvalue(tcl.slider.big))
id <- length(visu.env$slider.values)
}
switch(value+1, id, visu.env$slider.values[id])
}
buildPtsSearchTree <- function()
{
#search tree not useful => not computed
if (is.element(visu.env$profile.mode, c("none", "constrained pairs")))
return()
#data required
if (is.null(visu.env$features$x.2D.pixel) || !length(visu.env$slider.values))
return()
visu.env$pts.search.tree <- SearchTrees::createTree(visu.env$features$x.2D.pixel[visu.env$slider.values,,drop=FALSE])
}
configureSliders <- function(values, reset=TRUE){
visu.env$slider.values <- values
slider.tune.max <- min(slider.max, length(visu.env$slider.values))
slider.big.max <- (ceiling((length(visu.env$slider.values))/slider.tune.max)-1)*slider.tune.max
tkconfigure(tk.slider.big, from=0, to=slider.big.max, res=slider.tune.max)
tkconfigure(tk.slider.big.label, text=paste("big tuning\n(step = ", slider.tune.max, ")", sep=""))
tkconfigure(tk.slider.tune, from=1, to=slider.tune.max, res=1)
tkconfigure(tk.slider.tune.label, text=paste("fine tuning\n(from 1 to ", slider.tune.max,")", sep=""))
if (!reset) {
setSlidersId( getSlidersValue(value=FALSE), value=FALSE)
} else {
tclvalue(tcl.slider.big) <- 0
tclvalue(tcl.slider.tune) <- 1
}
}
#binded to tk.slider... Warning : button release dealt by OnPlotSample
#updates profile.*.id and plot profiles
OnSliderMove <- function(...) {
if (visu.env$profile.mode=="constrained pairs") {
setProfileIdsPair(getSlidersValue())
OnPlotSample()
} else {
setProfileId("sel", getSlidersValue())
setProfileId("fig", getSlidersValue())
}
}
updateProfilesPlot <- function(names=c("fig","mem")) {
if (is.element("fig", names))
tkrreplot(tk.profile.fig)
if (is.element("mem", names))
tkrreplot(tk.profile.mem)
if (visu.env$mem.mode) {
pair.status <- ""
pair <- c(visu.env$profile.id["sel"], visu.env$profile.id["mem"])
w <- which.pair(pair, visu.env$pairs.values)
if (!is.null(w))
pair.status <- switch(2+visu.env$pairs.constraints[w], "CNL","", "ML")
tkconfigure(tk.pairs.label, text=paste(pair.status, "Pair", paste(pair,
collapse=",")))
}
if (selection.mode=="prototypes"){
w <- visu.env$profile.id["sel"]
if (!is.na(w))
{
cluster <- NA
if (length(visu.env$prototypes[[visu.env$clustering.name]]))
cluster <- visu.env$prototypes[[visu.env$clustering.name]][w]
if (is.na(cluster))
cluster <- as.character(visu.env$features$label[w])
tclvalue(visu.env$tcl.proto.label) <- cluster
}
}
}
#----------------------------------------------------------------------------------------
# Pairs functions
#----------------------------------------------------------------------------------------
setMemMode <-function(bool) {
visu.env$mem.mode <- bool
if (!visu.env$mem.mode) {
tkpack.forget(tk.profile.mem)
} else
tkpack(tk.profile.mem, fill="x")
}
OnMemHide <- function() {
setMemMode(FALSE)
OnPlotSample()
}
ChangeProfileMode <- function() {
if (visu.env$ProfileModeNumber < 3){
visu.env$ProfileModeNumber <- visu.env$ProfileModeNumber + 1
} else {
visu.env$ProfileModeNumber <- 1
}
OnPlotProfile()
OnPlotProfile2()
}
OnMem <- function() {
setMemMode(TRUE)
setProfileId("mem", visu.env$profile.id["sel"])
OnPlotSample()
}
OnML <- function() {
if (!visu.env$mem.mode)
return() # message
pair <- c(visu.env$profile.id["sel"], visu.env$profile.id["mem"])
w <- which.pair(pair, visu.env$pairs.values)
if (is.null(w)){
visu.env$pairs.values <- c(visu.env$pairs.values, list(pair))
visu.env$pairs.constraints <- c(visu.env$pairs.constraints, +1)
} else
visu.env$pairs.constraints[w] <- +1
tkconfigure(tk.pairs.label, text=paste("ML", "Pair", paste(pair, collapse=",")))
OnPlotSample()
}
OnCNL <- function() {
if (!visu.env$mem.mode)
return() # message
pair <- c(visu.env$profile.id["sel"], visu.env$profile.id["mem"])
w <- which.pair(pair, visu.env$pairs.values)
if (is.null(w)){
visu.env$pairs.values <- c(visu.env$pairs.values, list(pair))
visu.env$pairs.constraints <- c(visu.env$pairs.constraints, -1)
} else
visu.env$pairs.constraints[w] <- -1
tkconfigure(tk.pairs.label, text=paste("CNL", "Pair", paste(pair, collapse=",")))
OnPlotSample()
}
OnCancelPair <- function() {
if (!visu.env$mem.mode)
return() # message
pair <- c(visu.env$profile.id["sel"], visu.env$profile.id["mem"])
w <- which.pair(pair, visu.env$pairs.values)
if (!is.null(w)){
visu.env$pairs.values <- visu.env$pairs.values[-w]
visu.env$pairs.constraints <- visu.env$pairs.constraints[-w]
}
tkconfigure(tk.pairs.label, text=paste("Pair", paste(pair, collapse=",")))
if (visu.env$profile.mode=="constrained pairs"){
if (!length(visu.env$pairs.values)) {
tclvalue(tcl.profile.mode) <- "none"
OnModifProfileMode()
} else {
configureSliders(visu.env$pairs.values, reset=FALSE) #settings BEFORE positioning !
OnSliderMove()
OnPlotSample()
}
}
}
OnValidPairs <- function() {
tkdestroy(tt)
}
which.pair <- function(pair, list.of.pairs) {
is.equal <- sapply(list.of.pairs, function(x) length(intersect(x, pair))==2)
if (!length(is.equal))
return()
res <- which(is.equal)
if (!length(res))
return()
res
}
#----------------------------------------------------------------------------------------
# Prototypes functions
#----------------------------------------------------------------------------------------
OnRenameCluster <- function() {
id <- visu.env$profile.id["sel"]
if (!nchar(tclvalue(visu.env$tcl.proto.label))) {
tclvalue(visu.env$tcl.proto.label) <- as.character(visu.env$label[id])
}
if (!is.na(id)){ ###A verifier
levels(visu.env$label)[which(levels(visu.env$label)==visu.env$label[id])] <- tclvalue(visu.env$tcl.proto.label)
visu.env$data.sample$clustering[[visu.env$clustering.name]]$label <- visu.env$label
}
buildMenuClustering()
buildMenuProfileMode()
OnModifProfileMode()
OnModifFeaturesMode()
OnPlotSample()
updateProfilesPlot()
}
OnSelectProto <- function() {
id <- visu.env$profile.id["sel"]
if (!nchar(tclvalue(visu.env$tcl.proto.label))) {
tclvalue(visu.env$tcl.proto.label) <- as.character(visu.env$label[id])
}
if (is.na(id)){ ###A verifier
visu.env$prototypes[[visu.env$clustering.name]] <- c(visu.env$prototypes[[visu.env$clustering.name]], tclvalue(visu.env$tcl.proto.label))
names(visu.env$prototypes[[visu.env$clustering.name]])[length(visu.env$prototypes[[visu.env$clustering.name]])] <- id
} else {
visu.env$prototypes[[visu.env$clustering.name]][id] <- tclvalue(visu.env$tcl.proto.label)
levels(visu.env$label)[which(levels(visu.env$label)==visu.env$label[id])] <- tclvalue(visu.env$tcl.proto.label)
visu.env$data.sample$clustering[[visu.env$clustering.name]]$label <- visu.env$label
}
buildMenuClustering()
buildMenuProfileMode()
OnModifProfileMode()
OnModifFeaturesMode()
OnPlotSample()
updateProfilesPlot()
}
OnCancelProto <- function() {
id <- visu.env$profile.id["sel"]
if (!is.na(id)){
visu.env$prototypes[[visu.env$clustering.name]] <- visu.env$prototypes[[visu.env$clustering.name]][names(visu.env$prototypes[[visu.env$clustering.name]]) != id]
if (visu.env$profile.mode=="prototypes"){
if (!length(visu.env$prototypes)) {
tclvalue(tcl.profile.mode) <- "none"
OnModifProfileMode()
} else {
configureSliders(names(visu.env$prototypes[[visu.env$clustering.name]][order(visu.env$prototypes[[visu.env$clustering.name]]$label)]), reset=FALSE) #settings BEFORE positioning !
OnSliderMove()
}
OnPlotSample()
}
updateProfilesPlot()
}
}
OnLeaveProto <- function() {
id <- visu.env$profile.id["sel"]
if (!is.na(id) && nchar(tclvalue(visu.env$tcl.proto.label))&&(!is.na(visu.env$prototypes[[visu.env$clustering.name]][id]))){
#prototypes[w] <- tclvalue(visu.env$tcl.proto.label)
visu.env$prototypes[[visu.env$clustering.name]][id] <- tclvalue(visu.env$tcl.proto.label)
updateProfilesPlot()
}
}
#----------------------------------------------------------------------------------------
# File clustering functions
#----------------------------------------------------------------------------------------
OnModifClusteringMode <- function() {
visu.env$previous.clustering.name <- visu.env$clustering.name
visu.env$clustering.name <- tclvalue(tcl.clustering.mode)
if (visu.env$clustering.name=="import clustering"){
filename.csv <- tclvalue(tkgetOpenFile(initialfile = "",
filetypes="{{csv Files} {.csv .CSV}}"))
res <- buildClusteringSample(filename.csv, visu.env$data.sample, RclusTool.env$param$preprocess$noise.cluster)
if ( !is.null(res) ) {
visu.env$clustering.name <- basename(filename.csv)
visu.env$data.sample$clustering[[visu.env$clustering.name]] <- res
visu.env$data.sample$clustering <-
c(visu.env$data.sample$clustering[-which(names(visu.env$data.sample$clustering)==visu.env$clustering.name)],
visu.env$data.sample$clustering[visu.env$clustering.name])
} else {
visu.env$clustering.name <- names(visu.env$data.sample$clustering[1])
}
}
tclvalue(tcl.clustering.mode) <- visu.env$clustering.name
visu.env$label <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$label
visu.env$cluster.summary <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary
if (visu.env$previous.clustering.name!=visu.env$clustering.name)
visu.env$previous.clustering.name <- visu.env$previous.clustering.name
buildMenuClustering()
buildMenuProfileMode()
OnModifProfileMode()
OnModifFeaturesMode()
OnModifPlotMode()
}
OnModifCompareMode <- function() {
visu.env$compare.mode <- tclvalue(tcl.compare.mode)
if (is.null(visu.env$previous.clustering.name) || (visu.env$previous.clustering.name == visu.env$clustering.name)) {
visu.env$compare.mode <- "off"
tclvalue(tcl.compare.mode) <- visu.env$compare.mode
return()
}
if (visu.env$compare.mode=="off") {
tkpack.forget(tk.plot.compare.frame)
} else {
if (visu.env$compare.mode=="comparison measure") {
warning("Function not implemented yet.")
#compareClusterings(visu.env$data.sample, c(visu.env$clustering.name, visu.env$previous.clustering.name))
visu.env$compare.mode <- "on" # env assignment should be better.
tclvalue(tcl.compare.mode) <- visu.env$compare.mode
}
tkpack(tk.plot.compare.frame, side="left", anchor="n")
OnPlotSample()
}
}
OnExportClustering <- function() {
filename.init <- paste("clustering ", RclusTool.env$gui$user.name, " ",
visu.env$clustering.name, ".csv", sep="")
rep.init <- visu.env$data.sample$files$results$clustering
params <- list(initialfile = filename.init, initialdir = rep.init,
filetypes="{{csv Files} {.csv .CSV}}")
if (!length(rep.init))
params$initialdir <- NULL
filename.csv <- tclvalue(do.call(tkgetSaveFile, params))
rep.final <- substr(filename.csv, 1, (nchar(filename.csv)-nchar(basename(filename.csv)))-1)
# saveClustering(filename.csv, label=visu.env$label, id.abs=rownames(visu.env$data.sample$features[[1]]$x))
saveClustering(filename.init, label=visu.env$label, dir=rep.final)
visu.env$data.sample$clustering[[visu.env$clustering.name]] <- buildClusteringSample(filename.csv, visu.env$data.sample, RclusTool.env$param$preprocess$noise.cluster)
}
OnExportSummary <- function() {
if (is.null(visu.env$cluster.summary)) {
tkmessageBox(message="First, select a clustering.")
return()
}
filename.init <- paste(visu.env$data.sample$name, " summary ", RclusTool.env$gui$user.name, " ",
visu.env$clustering.name, ".csv", sep="")
rep.init <- visu.env$data.sample$files$results$clustering
params <- list(initialfile = filename.init, initialdir = rep.init,
filetypes="{{csv Files} {.csv .CSV}}")
if (!length(rep.init))
params$initialdir <- NULL
filename.csv <- tclvalue(do.call(tkgetSaveFile, params))
rep.final <- substr(filename.csv, 1, (nchar(filename.csv)-nchar(basename(filename.csv)))-1)
# saveSummary(filename.csv=filename.csv, cluster.summary=visu.env$cluster.summary,
# data.sample=visu.env$data.sample, operator.name=RclusTool.env$gui$user.name, method.name=visu.env$clustering.name)
saveSummary(filename.csv=filename.init, cluster.summary=visu.env$cluster.summary, dir=rep.final)
}
# OnCountItems <- function() {
# if (is.character(visu.env$data.sample$files$images)) {
# #dev.off()
# countItemsSampleGUI(visu.env$data.sample, RclusTool.env=RclusTool.env)
# } else
# tkmessageBox(message = "No images to process!", icon = "warning", type = "ok")
# }
#
# OnApplyItems <- function() {
# computeItemsSampleGUI(visu.env$data.sample, method.select = visu.env$clustering.name, RclusTool.env=RclusTool.env)
# }
#----------------------------------------------------------------------------------------
# GUI
#----------------------------------------------------------------------------------------
tt <- tktoplevel(bg="white");
tkwm.title(tt,"Sample visualization")
# tkwm.geometry(tt,"670x680+0+0")
#--------------------
#definition of menus
#--------------------
buildMenuInitialFeatures <- function() {
tkdelete(tk.axis.menu, 0, "end")
tkadd(tk.axis.menu, "command", label=paste("H-axis:",visu.env$parH), command=cat)
tkadd(tk.axis.menu, "command", label=paste("V-axis:",visu.env$parV), command=cat)
tkadd(tk.axis.menu, "command", label="Modify H-axis", command=OnModifAxisH)
tkadd(tk.axis.menu, "command", label="Modify V-axis", command=OnModifAxisV)
}
buildMenuProfileMode <- function() {
tkdelete(tk.profile.mode.menu, 0, "end")
tkadd(tk.profile.mode.menu, "radio", label="none", variable=tcl.profile.mode,
command=OnModifProfileMode)
tkadd(tk.profile.mode.menu, "radio", label="whole sample", variable=tcl.profile.mode,
command=OnModifProfileMode)
tkadd(tk.profile.mode.menu, "radio", label="items with signal(s)", variable=tcl.profile.mode,
command=OnModifProfileMode)
tkadd(tk.profile.mode.menu, "radio", label="items with image(s)", variable=tcl.profile.mode,
command=OnModifProfileMode)
# if (!is.null(prototype.ids))
tkadd(tk.profile.mode.menu, "radio", label="prototypes", variable=tcl.profile.mode,
command=OnModifProfileMode)
tkadd(tk.profile.mode.menu, "radio", label="constrained pairs", variable=tcl.profile.mode,
command=OnModifProfileMode)
for (lev in levels(visu.env$label))
tkadd(tk.profile.mode.menu, "radio", label=lev, variable=tcl.profile.mode,
command=OnModifProfileMode)
}
buildMenuSummary <- function(){
tkdelete(tk.summary.mode.menu, 0, "end")
summary.feats <- extractFeaturesFromSummary(visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary)
if (!is.null(summary)){
for (s in summary.feats$simple.feats)
tkadd(tk.summary.mode.menu, "command", label=s, command=function(){ OnSimpleFeatSummary(s)})
tkadd(tk.summary.mode.menu, "command", label="Select Your Parameters", command=OnFeatFunSummary)
}
}
buildMenuClustering <- function() {
tkdelete(tk.clustering.menu, 0, "end")
tkadd(tk.clustering.menu, "radio", label="import clustering", variable=tcl.clustering.mode,
command=OnModifClusteringMode)
tkadd(tk.clustering.menu, "command", label="export clustering", command=OnExportClustering)
tkadd(tk.clustering.menu, "command", label="export summary", command=OnExportSummary)
# tkadd(tk.clustering.menu, "command", label="count items from images", command=OnCountItems)
# tkadd(tk.clustering.menu, "command", label="apply items counts models", command=OnApplyItems)
for (name in names(visu.env$data.sample$clustering))
tkadd(tk.clustering.menu, "radio", label=name, variable=tcl.clustering.mode,
command=OnModifClusteringMode)
}
tk.topmenu <- tkmenu(tt, tearoff=FALSE)
tkconfigure(tt, menu=tk.topmenu)
tkconfigure(tk.topmenu, font=visu.env$tk.font)
tk.plot.mode.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.plot.mode.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Plot type", menu=tk.plot.mode.menu)
tkadd(tk.plot.mode.menu, "radio", label="scatter-plot", variable=tcl.plot.mode,
value="scatter-plot", command=OnModifPlotMode)
tkadd(tk.plot.mode.menu, "radio", label="density-plot", variable=tcl.plot.mode,
value="density-plot", command=OnModifPlotMode)
tkadd(tk.plot.mode.menu, "radio", label="clusters summary", variable=tcl.plot.mode,
value="clusters summary", command=OnModifPlotMode)
tkadd(tk.plot.mode.menu, "radio", label="variables density by cluster", variable=tcl.plot.mode,
value="variables density by cluster", command=OnModifPlotMode)
tk.features.mode.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.features.mode.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Features space", menu=tk.features.mode.menu)
for (name in sortCharAsNum(names(visu.env$data.sample$features)))
tkadd(tk.features.mode.menu, "radio", label=featSpaceNameConvert(name, short2long=TRUE, RclusTool.env), variable=tcl.features.mode,
value=name, command=OnModifFeaturesMode)
tk.axis.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.axis.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Scatter Plot-axis", menu=tk.axis.menu)
if (!is.null(visu.env$cluster.summary)) {
tk.summary.mode.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.summary.mode.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Clusters summaries", menu=tk.summary.mode.menu)
buildMenuSummary()
}
tk.profile.mode.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.profile.mode.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Signals/Images view", menu=tk.profile.mode.menu)
tk.clustering.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.clustering.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Clustering", menu=tk.clustering.menu)
tk.compare.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.compare.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Comparison", menu=tk.compare.menu)
tkadd(tk.compare.menu, "radio", label="off", variable=tcl.compare.mode,
value="off", command=OnModifCompareMode)
tkadd(tk.compare.menu, "radio", label="on", variable=tcl.compare.mode,
value="on", command=OnModifCompareMode)
#tkadd(tk.compare.menu, "radio", label="comparison measure", variable=tcl.compare.mode,
# value="comparison measure", command=OnModifCompareMode)
buildMenuProfileMode()
buildMenuClustering()
#------------------
#frames and figures
#------------------
tk.plot.frame <- tkframe(tt, bg="white")
tk.profile.frame <- tkframe(tt, bg="white")
visu.env$plotSampleFunction <- function(...){plot(1)}
tk.plot.fig <- tkrplot.RclusTool(tk.plot.frame, fun=plotSample, hscale=RclusTool.env$param$visu$hscale+0.4, vscale=RclusTool.env$param$visu$hscale+0.2)
tkbind(tk.plot.fig, "<Motion>", OnMovePlotFun)
tkbind(tk.plot.fig, "<Button-1>", OnMouseClick)
tkbind(tk.plot.fig, "<Leave>", OnLeavePlot)
tk.plot.compare.frame <- tkframe(tt, bg="white")
tk.plot.compare.fig <- tkrplot.RclusTool(tk.plot.compare.frame, fun=plotSampleCompare, hscale=RclusTool.env$param$visu$hscale+0.4, vscale=RclusTool.env$param$visu$hscale+0.2)
tk.profile.fig <- tkrplot(tk.profile.frame, fun=OnPlotProfile, hscale=(RclusTool.env$param$visu$hscale)*RclusTool.env$param$visu$scale.graphics, vscale=0.6*RclusTool.env$param$visu$hscale*RclusTool.env$param$visu$scale.graphics)
tk.profile.mem <- tkrplot(tk.profile.frame, fun=OnPlotProfile2, hscale=(RclusTool.env$param$visu$hscale)*RclusTool.env$param$visu$scale.graphics, vscale=0.6*RclusTool.env$param$visu$hscale*RclusTool.env$param$visu$scale.graphics)
tk.slider.frame <- tkframe(tk.profile.frame, bg="white")
tk.slider.left.frame <- tkframe(tk.slider.frame, bg="white")
tk.slider.center.frame <- tkframe(tk.slider.frame, bg="white")
tk.slider.right.frame <- tkframe(tk.slider.frame, bg="white")
tk.slider.big <- tkscale(tk.slider.center.frame, length=450, bg="white",
command=OnSliderMove,
showvalue=TRUE, variable=tcl.slider.big, orient="horizontal")
tk.slider.tune <- tkscale(tk.slider.center.frame, length=450, bg="white",
command=OnSliderMove,
showvalue=TRUE, variable=tcl.slider.tune, orient="horizontal")
tk.slider.tune.label <- tklabel(tk.slider.right.frame, text="fine tuning", fg="black", bg="white", font=visu.env$tk.font)
tk.slider.big.label <- tklabel(tk.slider.right.frame, text="big tuning", fg="black", bg="white", font=visu.env$tk.font)
tkbind(tk.slider.big, "<ButtonRelease-1>", OnPlotSample) #Sample plotted only when mouse released
tkbind(tk.slider.big, "<ButtonRelease-2>", OnPlotSample) #Sample plotted only when mouse released
tkbind(tk.slider.tune, "<ButtonRelease-1>", OnPlotSample)
tkbind(tk.slider.tune, "<ButtonRelease-2>", OnPlotSample)
tk.mem.but <- tkbutton(tk.slider.left.frame, text="MR", command=OnMem, font=visu.env$tk.font)
tk.mem.hide.but <- tkbutton(tk.slider.left.frame, text="MC", command=OnMemHide, font=visu.env$tk.font)
tk.change.profile.mode <- tkbutton(tk.slider.left.frame, text="CPM", command=ChangeProfileMode, font=visu.env$tk.font)
tk.pairs.frame <- tkframe(tk.plot.frame, bg="white")
tk.pairs.valid.but <- tkbutton(tk.pairs.frame, text="Valid set of pairs", command=OnValidPairs, font=visu.env$tk.font)
tk.pairs.buts.frame <- tkframe(tk.pairs.frame, bg="white")
tk.pairs.label <- tklabel(tk.pairs.buts.frame, bg="white", fg="black", width=20, font=visu.env$tk.font)
tk.pairs.ML.but <- tkbutton(tk.pairs.buts.frame, text="ML Pair", command=OnML, font=visu.env$tk.font)
tk.pairs.CNL.but <- tkbutton(tk.pairs.buts.frame, text="CNL Pair", command=OnCNL, font=visu.env$tk.font)
tk.pairs.cancel.but <- tkbutton(tk.pairs.buts.frame, text="Cancel pair", command=OnCancelPair, font=visu.env$tk.font)
tk.protos.frame <- tkframe(tk.plot.frame, bg="white")
#tk.protos.valid.but <- tkbutton(tk.protos.frame, text="Valid set\nof protos", command=OnValidPairs)
tk.protos.buts.frame <- tkframe(tk.protos.frame, bg="white")
tk.protos.entry <- tkentry(tk.protos.frame, textvariable=visu.env$tcl.proto.label, width=50,
justify="left", fg="black", bg="white", font=visu.env$tk.font)
tk.cluster.rename.but <- tkbutton(tk.protos.buts.frame, text="Rename\ncluster", command=OnRenameCluster, font=visu.env$tk.font)
tk.protos.select.but <- tkbutton(tk.protos.buts.frame, text="Select\nproto", command=OnSelectProto, font=visu.env$tk.font)
tk.protos.cancel.but <- tkbutton(tk.protos.buts.frame, text="Cancel\nproto", command=OnCancelProto, font=visu.env$tk.font)
tkbind(tk.protos.entry, "<Leave>", OnLeaveProto)
#------------------
#positioning
#------------------
tkpack(tklabel(tk.plot.frame, text=visu.env$data.sample$name, fg="black",
bg="white", wraplength=600, font=visu.env$tk.font), fill="x")
tkpack(tk.plot.fig, fill="x")
tkpack(tk.plot.frame, side="left")
tkpack(tklabel(tk.plot.compare.frame, text=visu.env$data.sample$name, fg="black",
bg="white", wraplength=600, font=visu.env$tk.font), fill="x")
tkpack(tk.plot.compare.fig, fill="x")
if (visu.env$compare.mode!="off")
tkpack(tk.plot.compare.frame, side="left", anchor="n")
tkpack(tk.profile.fig, fill="x")
tkpack(tk.slider.big.label)
tkpack(tk.slider.big, fill="x")
tkpack(tk.slider.tune.label)
tkpack(tk.slider.tune, fill="x")
tkpack(tk.mem.but, fill="x")
tkpack(tk.mem.hide.but, fill="x")
tkpack(tk.change.profile.mode, fill="x")
tkpack(tk.slider.left.frame, side="left")
tkpack(tk.slider.center.frame, side="left")
tkpack(tk.slider.right.frame, side="left")
tkpack(tk.slider.frame, fill="x")
# tkpack(tk.profile.mem, sticky="n") #hidden
tkpack(tk.pairs.buts.frame, side="left")
tkpack(tk.pairs.valid.but, side="right")
tkpack(tk.pairs.label, side="left")
tkpack(tk.pairs.ML.but, side="left")
tkpack(tk.pairs.cancel.but, side="left")
tkpack(tk.pairs.CNL.but, side="left")
if (selection.mode=="pairs")
tkpack(tk.pairs.frame, fill="x")
tkpack(tk.protos.entry, side="left", padx=4)
tkpack(tk.protos.buts.frame, side="right")
#tkpack(tk.protos.valid.but, side="right")
tkpack(tk.cluster.rename.but, side="left")
tkpack(tk.protos.select.but, side="left")
tkpack(tk.protos.cancel.but, side="left")
if (selection.mode=="prototypes")
tkpack(tk.protos.frame, fill="x")
# tkpack(tk.profile.frame, side="right", padx=10, ipadx=10)
#initialisations
OnModifFeaturesMode()
OnModifPlotMode()
#horizontal axis - modification of feature
# ttt <- tkframe(tt)
# tkgrid(ttt, row=0, column=0, sticky="nw", padx=10)
# tkgrid(tklabel(ttt, text="Feature - First axis"), sticky="n")
# for (i in 1:length(feat)) {
# but <- tkradiobutton(ttt)
# tkconfigure(but, variable=featH.var, text=feat[i], value=feat[i], command=OnModif)
# tkgrid(but, sticky="w")
# }
# OnOK <- function(){
# tkdestroy(tt)
# }
# OK.but <- tkbutton(tt,text="End",command=OnOK)
# tkgrid(OK.but,row=14,column=1)
#default vizualisation
if ((selection.mode!="none")||wait.close)
tkwait.window(tt) ## A COMMENTER POUR LES TESTS
switch(selection.mode,
"prototypes"=list(prototypes=visu.env$prototypes,label=visu.env$data.sample$clustering),
"pairs"=list(ML=visu.env$pairs.values[visu.env$pairs.constraints==1],
CNL=visu.env$pairs.values[visu.env$pairs.constraints==-1]),
NULL
)
}
#' analyzePlot creates specific plot for data exploration/analysis.
#' @title Plot for data exploration/analysis
#' @description Create some specific plots for data exploration/analysis.
#' @param nb notebook in which the analyze plot will be added.
#' @param data.sample list containing features, profiles and clustering results.
#' @param selectedVar character vector containing the selected variables names to analyze.
#' @param type character vector specifying the analysis type. Must be 'boxplot', 'gapSE', 'histo', 'pcaCorr' or 'pcaVar'.
#' @param hscale numeric value corresponding to the horizontal scale of graphic.
#' @param K.max maximal number of clusters (K.Max=20 by default).
#' @param fontsize size of font (fontsize=11 by default).
#' @return None
#' @importFrom graphics barplot par layout boxplot title hist plot arrows text axis abline mtext box
#' @importFrom grDevices colorRampPalette
#' @importFrom corrplot corrplot
#' @importFrom stats cor
#' @import factoextra
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf <- tempfile()
#' write.table(dat, tf, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf)
#'
#' mainWindow <- tktoplevel()
#' tktitle(mainWindow) <- "Barplot clustering"
#' mainWindow$env$nb <- tk2notebook(mainWindow, tabs = c())
#' tkpack(mainWindow$env$nb, fill="both", expand= TRUE)
#'
#' analyzePlot(mainWindow$env$nb, x, selectedVar="x", type="boxplot")
#'
#'
#' @keywords internal
#'
analyzePlot <- function(nb, data.sample, selectedVar, type = "boxplot", hscale = 1.2, K.max=20, fontsize=11) {
datTemp <- data.sample$features[["preprocessed"]]$x[data.sample$id.clean,
which(colnames(data.sample$features[["preprocessed"]]$x) %in% selectedVar)]
# Check if all values are numeric
if (all(sapply(datTemp, is.numeric))) {
# Boxplot for selected parameter
if (type == "boxplot") {
tk2add.notetab(nb, " Statistics ", "Statistics")
tk2draw.notetab(nb, "Statistics", hscale = hscale,
function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg = "white", oma = c(0,2,2,0))
graphics::layout(matrix(c(1,2), 1, 2, byrow = TRUE), widths=c(1.5,2.5))
bp <- graphics::boxplot(data.sample$features[["preprocessed"]]$x[data.sample$id.clean,
which(colnames(data.sample$features[["preprocessed"]]$x) %in% selectedVar)],
main = NULL, ylab = "Values", outline = FALSE, col="black")
graphics::title(sub = paste("Max: ", toString(signif(bp$stats[5], digits = 5)),
"\n3rd quartile: ", toString(signif(bp$stats[4], digits = 5)),
"\nMedian: ", toString(signif(bp$stats[3], digits = 5)),
"\n1st quartile: ", toString(signif(bp$stats[2], digits = 5)),
"\nMin: ", toString(signif(bp$stats[1], digits = 5)), "\n", sep = ""),
adj = 1, font.sub = 1, cex.sub = 0.8)
graphics::hist(data.sample$features[["preprocessed"]]$x[data.sample$id.clean,
which(colnames(data.sample$features[["preprocessed"]]$x) %in% selectedVar)],
main = NULL, xlab = "Values", col="black")
graphics::title(selectedVar, outer=TRUE)
}
)
}
# Correlation circle from PCA for selected parameters
if (type == "pcaCorr") {
res.pca <- data.sample$features[[selectedVar]]$save
tk2add.notetab(nb, " PCA Correlation ", "pcaCorr")
tk2draw.notetab(nb, "pcaCorr", hscale = hscale,
function() {
p <- factoextra::fviz_pca_var(res.pca,
col.var = "contrib",
gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
repel = TRUE)
p <- p + ggplot2::theme(text = element_text(size = fontsize),
axis.title = element_text(size = fontsize),
axis.text = element_text(size = fontsize))
plot(p)
})
}
# Variances from PCA for selected parameters
if (type == "pcaVar") {
eig <- (data.sample$features[[selectedVar]]$sdev)^2
variance <- eig*100/sum(eig)
df=data.frame(Variance=variance ,CumVariance=cumsum(variance))
tk2add.notetab(nb, " PCA Variance ", "pcaVar")
tk2draw.notetab(nb, "pcaVar", hscale = hscale,
function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
xcoord <- seq(0.7, length(variance) * 1.2, by = 1.2)
graphics::par(bg = "white", mar = c(4,4,1,4)+.1)
bp <- graphics::barplot(variance, ylab = "Percentage of variance (%)",
xlim = c(0.2, xcoord[length(variance)]), col = "black")
graphics::axis(side = 1, at = bp, labels = paste("PC", 1:length(variance)))
graphics::par(new = TRUE)
graphics::plot(bp, cumsum(variance), xlim = c(0.2, xcoord[length(variance)]),
type = "o", col = "red", ylim = c(0, 100), lwd = 3, ann = FALSE, axes = FALSE)
graphics::axis(side = 4, col = "red", col.axis = "red")
graphics::mtext("Cumulative variance (%)", side = 4, line = 3, col = "red")
})
}
# Gap and K estimated from Spectral Embedding
if (type == "gapSE") {
length.eig <- length(data.sample$features[[selectedVar]]$eig)
eig <- data.sample$features[[selectedVar]]$eig[1:min(length.eig)]
gap <- data.sample$features[[selectedVar]]$gap
tk2add.notetab(nb, " Gap Spectral ", "gapSE")
tk2draw.notetab(nb, "gapSE", hscale = hscale,
function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg = "white")
graphics::plot(eig, type = "o", col = "blue", lwd = 3, ann = FALSE, axes = FALSE)
graphics::abline(v = which.max(gap), lwd = 2, lty = 2, col = "darkred")
graphics::abline(h = eig[which.max(gap)], lwd = 2, lty = 2, col = "darkred")
graphics::axis(side = 1, at = c(seq(0,K.max, by=5), which.max(gap)),
labels = c(seq(0,K.max, by=5), which.max(gap)), cex.axis = .7)
graphics::axis(side = 2, at = c(min(eig),max(eig)),
labels = c(signif(min(eig),2), max(eig)), las = 2, cex.axis = .7)
graphics::text(x = which.max(gap), y = max(eig)-0.01, "K", srt = 0, pos = 4, cex = .7, col = "darkred")
graphics::mtext("Index", side = 1, line = 3, col = "black")
graphics::mtext("Eigenvalue", side = 2, line = 3, col = "black")
graphics::box()
})
}
# Correlation circle
if (type == "Corr") {
data <- data.sample$features[["preprocessed"]]$x[data.sample$id.clean,selectedVar]
M <- stats::cor(data)
p.mat <- NULL
title.mat <- "Correlation matrix"
tryCatch(
expr = {
p.mat <- cor.mtest(M)
title.mat <- "Correlation matrix (p-value 5%)"
},
error = function(e){
if (grepl('not enough finite observations',as.character(e))==TRUE){
message("Not compatible with p-value test : not enough finite observations")
}
}
)
tk2add.notetab(nb, " Correlations ", "Corr")
tk2draw.notetab(nb, "Corr", hscale = hscale,
function() {
col <- grDevices::colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))
if (length(selectedVar) > 12){
corrplot::corrplot(M, type="upper", order="hclust", col=col(200),
p.mat = p.mat, sig.level = 0.05, insig = "blank", tl.col="black",
diag=FALSE,title= title.mat, mar=c(0,0,1,0), tl.cex= fontsize/11, cl.cex = fontsize/11, number.cex=fontsize/11)
} else {
corrplot::corrplot(M, method="color", col=col(200),
type="upper", order="hclust",
addCoef.col = "black",
tl.col="black", tl.srt=45,
p.mat = p.mat, sig.level = 0.05, insig = "blank",
diag=FALSE, title= title.mat, mar=c(0,0,1,0), tl.cex= fontsize/11, cl.cex = fontsize/11, number.cex=fontsize/11)
}
})
}
} else {
tkmessageBox(message = "Non numeric value(s) in the selected parameter(s)!", icon = "warning", type = "ok")
}
}
#' cor.mtest Correlation test on correlation matrix.
#' @title Correlation test.
#' @description Display the abundances barplot of a clustering.
#' @param mat correlation matrix
#' @return matrix with p-values.
#' @importFrom stats cor.test
#' @references \url{http://www.sthda.com/french/wiki/visualiser-une-matrice-de-correlation-par-un-correlogramme}
#' @keywords internal
cor.mtest <- function(mat) {
mat <- as.matrix(mat)
n <- ncol(mat)
p.mat<- matrix(NA, n, n)
diag(p.mat) <- 0
for (i in 1:(n - 1)) {
for (j in (i + 1):n) {
tmp <- stats::cor.test(mat[, i], mat[, j])
p.mat[i, j] <- p.mat[j, i] <- tmp$p.value
}
}
colnames(p.mat) <- rownames(p.mat) <- colnames(mat)
p.mat
}
#' abdPlotTabs displays the abundances barplot of a set of clusterings in Tk tabs of a notebook.
#' @title Abundances barplots inside Tk tabs.
#' @description Display the abundances barplot of a clustering.
#' @param clusterings clustering list.
#' @param nb a notebook.
#' @param RclusTool.env environment in which all global parameters, raw data and results are stored.
#' @param hscale numeric value corresponding to the horizontal scale of graphic.
#' @return None
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf <- tempfile()
#' write.table(dat, tf, sep=",", dec=".")
#'
#' mainWindow <- tktoplevel()
#' tktitle(mainWindow) <- "Barplot clustering"
#' mainWindow$env$nb <- tk2notebook(mainWindow, tabs = c())
#' tkpack(mainWindow$env$nb, fill="both", expand= TRUE)
#'
#' x <- importSample(file.features=tf)
#' method <- "K-means"
#'
#' x <- computeUnSupervised(x, K=3, method.name=method)
#'
#' abdPlotTabs(x$clustering, mainWindow$env$nb)
#'
#'
#' @keywords internal
#'
abdPlotTabs <- function(clusterings, nb, RclusTool.env=initParameters(), hscale=NULL)
{
if (is.null(hscale))
hscale <- 1.2
num.cluster <- 0
for (title in names(clusterings))
{
if (title == "no-clustering")
next
num.cluster <- num.cluster + 1
label <- clusterings[[title]]$label
text <- paste("", as.character(num.cluster),"")
tk2add.notetab(nb, text, as.character(num.cluster))
tk2draw.notetab(nb, as.character(num.cluster), hscale= hscale,
function() abdPlot(label, title, point.param=RclusTool.env$param$visu$palette.colors))
}
}
#' abdPlotTabsGUI calls abdPlotTabs to display the abundances barplot of the clusterings of the current RclusTool.env$data.sample, inside the GUI.
#' @title Abundances barplots inside Tk tabs.
#' @description Display the abundances barplot of a clustering.
#' @param RclusTool.env environment in which all global parameters, raw data and results are stored.
#' @return None
#'
#' @keywords internal
abdPlotTabsGUI <- function(RclusTool.env=initParameters())
{
clusterings <- RclusTool.env$data.sample$clustering
nb <- RclusTool.env$gui$win2$env$nb
hscale <- RclusTool.env$param$visu$hscale
if (!is.null(clusterings) && !is.null(nb))
abdPlotTabs(clusterings, nb, RclusTool.env, hscale=hscale)
}
#' abdPlot displays the abundances barplot of a clustering.
#' @title Abundances barplot
#' @description Display the abundances barplot of a clustering.
#' @param label factor describing the clustering.
#' @param title naming the graph.
#' @param charsize character size
#' @param point.param specifying the colors and the symbols to use for clusters display.
#' @return None
#' @importFrom grDevices colors
#' @importFrom graphics par barplot
#' @import ggplot2
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf <- tempfile()
#' write.table(dat, tf, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf)
#'
#' x <- computeUnSupervised(x, K=3, method.name='K-means')
#'
#' abdPlot(x[["clustering"]][["K-means_preprocessed"]][["label"]], 'K-means_preprocessed')
#'
#'
#' @keywords internal
#'
abdPlot <- function(label, title, charsize=11, point.param=c("grey","black","red","blue","green","cyan", "yellow","orange",
"rosybrown","palevioletred","darkblue","deeppink","blueviolet", 'darkgoldenrod1', 'chartreuse',
"darkorchid1", "deeppink", "coral", "darkolivegreen1","#66C2A5","#9DAE8C","#D49A73","#F08F6D",
"#C79693","#9E9DBA","#9F9BC9","#C193C6","#E28BC3","#D2A29F","#BABF77","#AAD852","#CBD844",
"#ECD836","#FAD53E","#F1CD64","#E7C689","#D7BF9C","#C5B9A7","#B3B3B3","#D53E4F","#E04F4A",
"#EB6046","#F47346","#F88B51","#FBA35C","#FDB869","#FDCA79","#FDDD88","#F6E68F","#EDEE93",
"#E2F398","#CDEA9D","#B7E2A1","#A0D8A4","#86CEA4","#6DC4A4","#58B2AB","#459DB4","#3288BD")){
l=levels(label)
id=names(label)
values=unname(label)
df<-data.frame(id=id,label=values)
p <- ggplot2::ggplot(df, aes(factor(label),fill=label)) + ggplot2::geom_bar() + ggplot2::scale_x_discrete(drop=FALSE)
p <- p + ggplot2::xlab("") + ggplot2::ylab("Abundances")
p <- p + ggplot2::ggtitle(title)
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::theme(axis.text.x = element_text(angle = 90, size=11))
p <- p + ggplot2::scale_fill_manual(values=point.param[1:length(l)], drop=FALSE)
p <- p + ggplot2::theme(legend.position='none')
p <- p + ggplot2::theme(axis.text.x = element_text(size = charsize))
p <- p + ggplot2::theme(axis.text.y = element_text(size = charsize))
p <- p + ggplot2::theme(plot.title = element_text(size = charsize))
print(p)
}
#' ElbowPlot displays the Elbow plot after a clustering step.
#' @title Elbow Plot.
#' @description Display the Elbow Plot after a clustering step.
#' @param nb tk-notebook in which the Elbow plot will be made.
#' @param method.space.name complete name of space.
#' @param RclusTool.env : environment in which data and intermediate results are stored.
#' @param hscale numeric value corresponding to the horizontal scale of graphic
#' @param charsize character size
#' @return None
#' @import ggplot2
#' @keywords internal
ElbowPlot <- function(nb, method.space.name, RclusTool.env, hscale= 1.2, charsize=11) {
Within=RclusTool.env$data.sample$clustering[[method.space.name]]$Within
K=ElbowFinder(1:length(Within),Within)
df=data.frame(K= 1:length(Within) , Within=Within)
tk2add.notetab(nb, " Elbow ", "Elbow")
tk2draw.notetab(nb, "Elbow", hscale= hscale,
function() {
tryCatch(
expr = {
p <- ggplot2::ggplot(data=df, ggplot2::aes(x=K, y=Within))
p <- p + ggplot2::geom_line(size=1) + geom_point()
p <- p + ggplot2::scale_color_manual(values=(col))
p <- p + ggplot2::xlab("K") + ggplot2::ylab("Withins tot")
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::ggtitle(paste('Elbow', method.space.name, sep=" "))
p <- p + ggplot2::geom_vline(xintercept = K, linetype="dashed", color = "red", size=1.5)
p <- p + ggplot2::scale_x_continuous(breaks=1:length(Within))
p <- p + ggplot2::theme(axis.text.x = element_text(size = charsize))
p <- p + ggplot2::theme(axis.text.y = element_text(size = charsize))
p <- p + ggplot2::theme(plot.title = element_text(size = charsize))
print(p)
},
error = function(e){
if (grepl('-monotype-arial',as.character(e))==TRUE){
message("Error :Please, Try to install gsfonts-x11")
}
}
)
}
)
}
#' tk2delete.notetab delete a notetab
#' @title Delete notetab inside a tk-notebook
#' @description Delete notetab inside a tk-notebook.
#' @param nb : a notebook.
#' @param tab.names : either NULL to delete all the notetabs, or a vector of notetab names.
#' @return None
#' @keywords internal
tk2delete.notetab <- function(nb, tab.names=NULL)
{
ids <- names(nb$env) # noms des objets
nt.ok <- sapply(ids, function(x) inherits(nb$env[[x]],"ttk2notetab"))
ids <- ids[nt.ok] #noms des onglets de classe tk2notetab
if (is.null(tab.names))
tab.names <- ids
for (id in tab.names)
{
tkdestroy(nb$env[[id]])
rm(list=id, envir=nb$env)
}
}
#' tk2add.notetab add a notetab.
#' @title Add notetab.
#' @description Add a notetab.
#' @param nb a notebook.
#' @param tab.label string the label of a tab on the interface.
#' @param tab.name string the name of the tab in a notebook.
#' @return None
#' @keywords internal
tk2add.notetab <- function(nb, tab.label, tab.name=NULL)
{
if (is.null(tab.name))
tab.name <- tab.label
tframe <- tk2frame(nb)
tkadd(nb, tframe, text=tab.label, sticky="nsew")
tk2notetab.RclusTool(nb, tab.label, tab.name)
}
#' tk2draw.notetab draw in a notetab.
#' @title Draw in a Notetab.
#' @description Draw in a Notetab with a function.
#' @param nb a notebook.
#' @param tab.name string : name of the tk2notetab variable.
#' @param hscale numeric value corresponding to the horizontal scale of graphic
#' @param fun : a function.
#' @return None
#' @keywords internal
tk2draw.notetab <- function(nb, tab.name, fun, hscale= 1.2){
Plot <- tkrplot.RclusTool(nb$env[[tab.name]], hscale = hscale, fun=fun)
tkgrid(Plot, row = 0, column = 1, sticky = "w")
}
#' tk2notetab.RclusTool RclusTool adaptation of tk2notetab.
#' @title RclusTool tk2notetab.
#' @description RclusTool adaptation of tk2notetab; builds and returns a R tk2notetab matching a notetab already declared in tk notebook.
#' @param nb a tk2notebook or ttk2notebook widget.
#' @param tab.label string the label of a tab on the interface.
#' @param tab.name string the name of the tab in a notebook.
#' @return None
#' @keywords internal
tk2notetab.RclusTool <- function (nb, tab.label, tab.name=NULL)
{
if (inherits(nb, "tk2notebook")) {
if (is.null(tab.name))
tab.name <- tab.label
ntab <- as.numeric(tcl(nb, "index", "end"))
if (ntab < 1)
return(NULL)
tabid <- ""
for (i in 0:(ntab - 1)) if (tclvalue(tcl(nb, "tab", i,
"-text")) == tab.label) {
tabid <- as.character(tcl(nb,"tabs"))[i+1]
break
}
if (tabid !="") {
w <- list()
w$ID <- tabid
w$env <- new.env()
w$env$num.subwin <- 0
w$env$parent <- nb
class(w) <- c("ttk2notetab", "tk2container", "tkwin")
nb$env[[tab.name]] <- w #sauvegarde dans l'environnement du notebook
return(w)
}
else return(NULL)
}
else stop("'nb' must be a 'tk2notebook' object")
}
#' tkrplot.RclusTool RclusTool adaptation of tkrplot.
#' @title RclusTool tkrplot.
#' @description RclusTool adaptation of tkrplot.
#' @param graphicFrame : frame of the RclusTool interface in which graphics should be displayed.
#' @param fun : a function
#' @param hscale numeric value corresponding to the horizontal scale of graphic
#' @param vscale : vertical scale
#' @return None
#' @importFrom grDevices png
#' @keywords internal
tkrplot.RclusTool <- function(graphicFrame, fun, hscale=1.0, vscale=1.0)
{
file <- tempfile()
grDevices::png(file, width=hscale*480, height=vscale*480)
try(fun())
dev.off()
image <- tclVar()
tkimage.create("photo", image, file = file)
lab <- tklabel(graphicFrame, image=image)
tkbind(lab, "<Destroy>", function() .Tcl(paste("image delete", image)))
lab$file <- file
lab$image <- image
lab$fun <- fun
lab$graphicFrame <- graphicFrame
lab$hscale <- hscale
lab$vscale <- vscale
lab
}
#' tkrreplot.RclusTool RclusTool adaptation of tkrreplot.
#' @title RclusTool tkrreplot.
#' @description RclusTool adaptation of tkrreplot.
#' @param env.graphic : graphic environment generated by tkrplot.RclusTool
#' @seealso \code{\link{tkrreplot.RclusTool}}
#' @return None
#' @importFrom grDevices png
#' @keywords internal
tkrreplot.RclusTool <- function(env.graphic)
{
grDevices::png(env.graphic$file, width=env.graphic$hscale*480, height=env.graphic$vscale*480)
try(env.graphic$fun())
dev.off()
tkimage.create("photo", env.graphic$image, file=env.graphic$file)
}
#' makeTitle Makes a title from a string.
#' @title RclusTool makeTitle.
#' @description Makes a character title from string by completion with a specified character.
#' @param string: string to be completed
#' @param length: final title length in characters
#' @param prefix.length: space length in front of the title
#' @param char: character used to complete the title
#' @return title
#' @keywords internal
makeTitle <- function(string, length=120, prefix.length=5, char='_'){
n.reps <- length - nchar(string) - prefix.length
if (n.reps<1)
return(string)
string_return <- paste(strrep(char, 5), string, strrep(char, n.reps), sep='')
return(string_return)
}
#' tkEmptyLine Inserts an empty line in a graphical tk objects dealt with grid.
#' @title RclusTool tkEmptyLine.
#' @description Makes a character title from string by completion with a specified character.
#' @param tk.object: tk object in which to insert the new line
#' @param row: row number of the insertion
#' @return None
#' @keywords internal
tkEmptyLine <- function(tk.object, row=NULL)
{
label <- tklabel(tk.object, text=" ")
if (!is.null(row)) {
tkgrid(label, row = row)
} else {
tkgrid(label)
}
}
#' consoleMessage Adds a message in the RclusTool GUI.
#' @title RclusTool consoleMessage.
#' @description Adds a message in the RclusTool GUI.
#' @param message: string to print in the console.
#' @param RclusTool.env environment in which all global parameters, raw data and results are stored.
#' @return None
#' @keywords internal
messageConsole <- function(message, RclusTool.env=initParameters())
{
console <- RclusTool.env$gui$console
if (!is.null(console))
{
tkinsert(console, "0.0", message)
}
}
Try the RclusTool package in your browser
Any scripts or data that you put into this service are public.
RclusTool documentation built on Aug. 29, 2022, 9:07 a.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 messageConsole tkEmptyLine makeTitle tkrreplot.RclusTool tkrplot.RclusTool tk2draw.notetab tk2add.notetab tk2delete.notetab ElbowPlot abdPlot abdPlotTabsGUI abdPlotTabs cor.mtest analyzePlot visualizeSampleClustering plotDensity2D plotSampleFeatures plotProfileExtract plotProfile
Documented in abdPlot abdPlotTabs abdPlotTabsGUI analyzePlot cor.mtest ElbowPlot makeTitle messageConsole plotDensity2D plotProfile plotProfileExtract plotSampleFeatures tk2add.notetab tk2delete.notetab tk2draw.notetab tkEmptyLine tkrplot.RclusTool tkrreplot.RclusTool visualizeSampleClustering
# RclusTool: clustering of items in datasets
#
# Copyright 2013 Guillaume Wacquet, Pierre-Alexandre Hebert, Emilie Poisson-Caillault
#
#
# 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 3 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, see <http://www.gnu.org/licenses/>.
#' plotProfile plots the profile and the image (if available) of a particle
#' @title Profile and image plotting
#' @description Plot the profile and the image (if available) of a particle.
#' @param profiles matrix of profile data (signals in columns).
#' @param profiles.colors vector of colors corresponding to each signal in profile.
#' @param image character vector specifying the name (without path) + extension of the associated image (if available).
#' @param curve.names vector of character specifying the names of each signal in profile.
#' @param title character vector specifying the title of the plot.
#' @param sub character vector specifying the subtitle of the plot.
#' @param sub.color character vector specifying the color of the subtitle.
#' @param image.dir images directory.
#' @param charsize character size
#' @return None
#' @importFrom graphics layout plot rasterImage matplot legend
#' @importFrom jpeg readJPEG
#' @importFrom png readPNG
#' @importFrom rlang .data
#' @import reshape ggplot2
#' @seealso \code{\link{plotSampleFeatures}}, \code{\link{visualizeSampleClustering}}
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf1 <- tempfile()
#' write.table(dat, tf1, sep=",", dec=".")
#'
#' sig <- data.frame(ID=rep(1:150, each=30), SIGNAL=rep(dnorm(seq(-2,2,length=30)),150))
#' tf2 <- tempfile()
#' write.table(sig, tf2, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf1, file.profiles=tf2)
#'
#' plotProfile(x$profiles[[1]])
#'
#'
#' @keywords internal
#'
plotProfile <- function(profiles, profiles.colors=NULL, image=NULL, curve.names=NULL, title="Some observation", sub="", sub.color=NULL, image.dir=NULL, charsize=11){
p <- ggplot() + ggplot2::ggtitle(paste(title,sub))
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::theme(axis.text.x = element_text(size = charsize))
p <- p + ggplot2::theme(axis.text.y = element_text(size = charsize))
p <- p + ggplot2::theme(plot.title = element_text(size = charsize))
nc <- ncol(profiles)
if (!is.null(nc)) {
if (is.null(curve.names))
curve.names <- colnames(profiles)
profiles.df<-as.data.frame(profiles)
profiles.df$line<-1:nrow(profiles.df)
profiles.df <- reshape::melt(profiles.df, id.vars="line")
# Everything on the same plot
p <- ggplot2::ggplot(profiles.df, ggplot2::aes(x=.data$line,y=.data$value,col=.data$variable)) + ggplot2::labs(col="Profiles")
p <- p + ggplot2::ggtitle(paste(title,sub))
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::xlab("") + ggplot2::ylab("Value")
}
if (is.null(image))
image <- NA
if (is.null(image.dir))
image.dir <- ""
if (!is.na(image)) {
imgFile <- file.path(image.dir, image)
readImg <- jpeg::readJPEG
if (!grepl(".jpg", imgFile))
readImg <- png::readPNG
if (grepl(".jpg", imgFile) || grepl(".png", imgFile)) {
img <- readImg(imgFile, native = TRUE)
}
p <- p + ggplot2::annotation_custom(grid::rasterGrob(img,
width = unit(1,"npc"),
height = unit(1,"npc")),
-Inf, Inf, -Inf, Inf)
}
if (!is.null(nc)) {
if (is.null(profiles.colors)){
profiles.colors <- rep("black", length(curve.names))
}
p <- p + ggplot2::geom_line(size=0.9)
p <- p + ggplot2::scale_color_manual(values= profiles.colors[1:nc])
}
print(p)
}
#' plotProfileExtract plots the profile and the image (if available) of a particle
#' @title Profile and image plotting
#' @description Plot the profile and the image (if available) of a particle.
#' @param profiles matrix of profile data (signals in columns).
#' @param profiles.colors vector of colors corresponding to each signal in profile.
#' @param image character vector specifying the name (without path) + extension of the associated image (if available).
#' @param curve.names vector of character specifying the names of each signal in profile.
#' @param title character vector specifying the title of the plot.
#' @param sub character vector specifying the subtitle of the plot.
#' @param sub.color character vector specifying the color of the subtitle.
#' @param image.dir images directory.
#' @return None
#' @importFrom graphics layout plot rasterImage matplot legend
#' @importFrom jpeg readJPEG
#' @importFrom png readPNG
#' @seealso \code{\link{plotSampleFeatures}}, \code{\link{visualizeSampleClustering}}
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf1 <- tempfile()
#' write.table(dat, tf1, sep=",", dec=".")
#'
#' sig <- data.frame(ID=rep(1:150, each=30), SIGNAL=rep(dnorm(seq(-2,2,length=30)),150))
#' tf2 <- tempfile()
#' write.table(sig, tf2, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf1, file.profiles=tf2)
#'
#' plotProfileExtract(x$profiles[[1]])
#'
#'
#' @keywords internal
#'
plotProfileExtract <- function(profiles, profiles.colors=NULL, image=NULL, curve.names=NULL, title="Some observation", sub="", sub.color=NULL, image.dir=NULL){
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
nc <- ncol(profiles)
if (is.null(image))
image <- NA
if (is.null(image.dir))
image.dir <- ""
dimLayout <- as.numeric(!is.null(nc)) + as.numeric(!is.na(image))
graphics::layout(matrix(c(1,dimLayout), 1, 2, byrow = TRUE), widths=rep(1, dimLayout))
par(mar=c(6,3,2,.2)) #bottom large because of sub parameter
if (!is.null(nc)) {
if (is.null(curve.names))
curve.names <- colnames(profiles)
#correspondances of colors
if (!is.null(profiles.colors)) {
curve.colors <- sapply(curve.names, function (x) {col<-profiles.colors[x];
if (is.na(col)) 'black' else col})
} else {
curve.colors <- rep("black", length(curve.names))
}
if (is.null(sub.color))
sub.color <- "black"
#matplot(profiles, pch=1:nc, type="o", col=curve.colors, main=title, sub=sub, col.sub=sub.color, ylab="level", cex = 0.8)
graphics::matplot(profiles, pch=1:nc, type="o", col=curve.colors, main=title, sub=sub, ylab="level", cex = 0.8)
if (!is.null(curve.names))
graphics::legend("topright", legend=curve.names, col=curve.colors, pch=1:nc, cex=0.8)
}
par(mar=c(5,.2,5,.2))
if (!is.na(image)) {
imgFile <- file.path(image.dir, image)
readImg <- jpeg::readJPEG
if (!grepl(".jpg", imgFile))
readImg <- png::readPNG
if (grepl(".jpg", imgFile) || grepl(".png", imgFile)) {
img <- readImg(imgFile, native = TRUE)
dimg <- dim(img)
h <- dimg[1]
w <- dimg[2]
graphics::plot(c(0, w), c(0, h), type = "n", xlab = "", ylab = "", axes = FALSE)
graphics::rasterImage(img, 0, 0, w, h)
}
}
}
#' plotSampleFeatures plots 2D-features scatter-plot of all particles
#' @title 2D-features scatter-plot
#' @description Plot 2D-features scatter-plot of all particles. Grey color (label=0) is for data to cleaned or to remove in classification process.
#' @param data matrix or data.frame of raw data (points by line).
#' @param label vector of labels.
#' @param parH character vector specifying the name of the feature to use as x-axis.
#' @param parV character vector specifying the name of the feature to use as y-axis.
#' @param figure.title character vector specifying the title of the scatter-plot.
#' @param logscale character vector containing "x" if the x-axis is to be logarithmic, "y" if the y-axis is to be logarithmic and "xy" or "yx" if both axes are to be logarithmic.
#' @param cex numeric value specifying the size of the graphical labels.
#' @param point.param data.frame specifying the colors and the symbols to use for clusters display.
#' @param env.plot environment where to store graphical parameters used by function PlotScatter to select points.
#' @return None
#' @importFrom grDevices colors
#' @importFrom graphics title plot abline legend par
#' @seealso \code{\link{plotProfile}}, \code{\link{visualizeSampleClustering}}
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf1 <- tempfile()
#' write.table(dat, tf1, sep=",", dec=".")
#'
#' sig <- data.frame(ID=rep(1:150, each=30), SIGNAL=rep(dnorm(seq(-2,2,length=30)),150))
#' tf2 <- tempfile()
#' write.table(sig, tf2, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf1, file.profiles=tf2)
#'
#' res <- KmeansQuick(x$features$initial$x, K=3)
#' new.labels <- formatLabelSample(res$cluster, x)
#'
#' plotSampleFeatures(x$features$initial$x, label = new.labels, parH="x", parV="y")
#'
#'
#' @keywords internal
#'
plotSampleFeatures<- function(data, label, parH=NULL, parV=NULL, figure.title="Scatter plot",
logscale="", cex=.8, point.param=expand.grid(
col=c("grey","black","red","blue","green","cyan", "yellow","orange",
"rosybrown","palevioletred","darkblue","deeppink","blueviolet", 'darkgoldenrod1', 'chartreuse',
"darkorchid1", "deeppink", "coral", "darkolivegreen1","#66C2A5","#9DAE8C","#D49A73","#F08F6D",
"#C79693","#9E9DBA","#9F9BC9","#C193C6","#E28BC3","#D2A29F","#BABF77","#AAD852","#CBD844",
"#ECD836","#FAD53E","#F1CD64","#E7C689","#D7BF9C","#C5B9A7","#B3B3B3","#D53E4F","#E04F4A",
"#EB6046","#F47346","#F88B51","#FBA35C","#FDB869","#FDCA79","#FDDD88","#F6E68F","#EDEE93",
"#E2F398","#CDEA9D","#B7E2A1","#A0D8A4","#86CEA4","#6DC4A4","#58B2AB","#459DB4","#3288BD"),
pch=c(20, 0:18), stringsAsFactors = FALSE), env.plot = NULL){
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
if (is.null(parH)) {
parH <- colnames(data)[1]
}
if (is.null(parV)) {
parH <- colnames(data)[2]
}
#numeros des clusters dans l'ordre
vlabel <- levels(label)
#construction des donnees
x <- data[, c(parH, parV), drop=FALSE]
if (cex==0.8){
graphics::par(mar=c(3.9, 3.9, 1.5, 10.5), xpd=TRUE)
} else if (cex==0.7) {
graphics::par(mar=c(3.9, 3.9, 1.5, 8.1), xpd=TRUE)
} else if (cex==0.6) {
graphics::par(mar=c(3.9, 3.9, 1.5, 7.1), xpd=TRUE)
}
#plot
graphics::plot(x, type="p", col=point.param$col[unclass(label)], pch=point.param$pch[unclass(label)],
cex=cex, cex.lab=cex, cex.sub=cex, cex.axis=cex, log=logscale, ann=FALSE) #pch=1, cex=.8, yaxt = "n",xaxt = "n");
graphics::abline( h = 0, lty = 3, col = grDevices::colors()[ 440 ] )
graphics::abline( v = 0, lty = 3, col = grDevices::colors()[ 440 ] )
#titles+legendes
graphics::title(figure.title, xlab=parH, ylab=parV, cex.main=cex)
coord <- graphics::par("usr")
graphics::legend("topright", legend=vlabel, col=point.param$col[1:length(vlabel)],
pch=point.param$pch[1:length(vlabel)], cex=cex, pt.cex=cex, inset=c(-0.25,0), box.lty=0)
if (!is.null(env.plot))
{
env.plot$parPlotSampleFeatures <- par(no.readonly=TRUE)
}
}
#' plotDensity2D plots density of a variable by cluster
#' @title plot Variables Density
#' @description Plots density of a variable by cluster.
#' @param data density data.frame with x,y and Cluster indication.
#' @param parH character vector specifying the name of the feature to use as x-axis.
#' @param clustering.name character vector specifying the name of the clustering.
#' @param charsize character size
#' @param col vector of colors
#' @return None
#' @import ggplot2
#'
#' @examples
#'
#' dat <- rbind(matrix(rnorm(100, mean = 0, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2))
#' tf <- tempfile()
#' write.table(dat, tf, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf)
#' x <- computeUnSupervised(x, K=3, method.name="K-means")
#'
#' label<-x[["clustering"]][["K-means_preprocessed"]][["label"]]
#'
#' cluster.density <- clusterDensity(x, label, "preprocessed",features.to.keep='V1')
#' plotDensity2D(cluster.density, clustering.name='Test Kmeans', parH='V1')
#'
#'
#' @keywords internal
#'
plotDensity2D <- function(data, parH=NULL, clustering.name, charsize = 11,
col=c("grey","black","red","blue","green","cyan", "yellow","orange",
"rosybrown","palevioletred","darkblue","deeppink","blueviolet", 'darkgoldenrod1', 'chartreuse',
"darkorchid1", "deeppink", "coral", "darkolivegreen1","#66C2A5","#9DAE8C","#D49A73","#F08F6D",
"#C79693","#9E9DBA","#9F9BC9","#C193C6","#E28BC3","#D2A29F","#BABF77","#AAD852","#CBD844",
"#ECD836","#FAD53E","#F1CD64","#E7C689","#D7BF9C","#C5B9A7","#B3B3B3","#D53E4F","#E04F4A",
"#EB6046","#F47346","#F88B51","#FBA35C","#FDB869","#FDCA79","#FDDD88","#F6E68F","#EDEE93",
"#E2F398","#CDEA9D","#B7E2A1","#A0D8A4","#86CEA4","#6DC4A4","#58B2AB","#459DB4","#3288BD")){
tryCatch(
expr = {
p <- ggplot2::ggplot(data=data, ggplot2::aes(x=data$x, y=data$y, colour=data$Cluster, shape=data$Cluster)) + ggplot2::labs(col="Cluster")
p <- p + ggplot2::geom_line(size=1) + ggplot2::scale_color_manual(values=(col))
p <- p + ggplot2::xlab(parH) + ggplot2::ylab("Density")
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::ggtitle(paste('Variables density plot by', clustering.name, sep=" "))
p <- p + ggplot2::theme(axis.text.x = element_text(size = charsize))
p <- p + ggplot2::theme(axis.text.y = element_text(size = charsize))
p <- p + ggplot2::theme(plot.title = element_text(size=charsize))
print(p)
},
error = function(e){
message(e)
if (grepl('-monotype-arial',as.character(e))==TRUE){
message("Error :Please, Try to install gsfonts-x11")
}
}
)
}
#' visualizeSampleClustering opens an interactive figure with 2D scatter-plot of all particles with axis choice
#' @title Interactive figure with 2D scatter-plot
#' @description Open an interactive figure with 2D scatter-plot of all particles with axis choice. Grey color (label=0) is for data to cleaned or to remove in classification process.
#' @param data.sample list containing features, profiles and clustering results.
#' @param label vector of labels.
#' @param clustering.name character vector specifying the clustering method used to get labels.
#' @param cluster.summary data.frame containing the clusters summaries (as returned by 'clusterSummary').
#' @param RclusTool.env environment in which all global parameters, raw data and results are stored.
#' @param prototypes list containing vectors of prototypes indices.
#' @param profile.mode character vector specifying the plot mode of profiles. Must be 'none' (default), 'whole sample', 'cluster i' or 'constrained pairs'.
#' @param selection.mode character vector specifying the selection mode of profiles. Must be 'none' (default), 'prototypes' or 'pairs'.
#' @param compare.mode character vector specifying the mode of comparison between two clusterings results. Must be 'off' (default) or 'on'.
#' @param pairs list of constrained pairs (must-link and cannot-link).
#' @param features.mode character vector specifying the plot mode of features (projection in a specific space). Must be 'initial' (default), 'preprocessed', 'pca', 'pca_full' or 'spectral', or prefixed versions ('sampled', 'scaled') of those space names.
#' @param wait.close boolean: if FALSE (default), the following steps of the analysis calculations are computed even if the window is not closed.
#' @param fontsize size of font (default is 9)
#' @return prototypes in \code{selection.mode} = "prototypes" mode, pairs in \code{selection.mode} = "pairs" mode.
#' @seealso \code{\link{plotProfile}}, \code{\link{plotSampleFeatures}}
#' @importFrom graphics barplot boxplot axis points filled.contour par
#' @importFrom SearchTrees createTree knnLookup
#' @importFrom grDevices gray topo.colors
#' @importFrom MASS kde2d
#' @import tcltk tcltk2 tkrplot ggplot2
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf1 <- tempfile()
#' write.table(dat, tf1, sep=",", dec=".")
#'
#' sig <- data.frame(ID=rep(1:150, each=30), SIGNAL=rep(dnorm(seq(-2,2,length=30)),150))
#' tf2 <- tempfile()
#' write.table(sig, tf2, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf1, file.profiles=tf2)
#'
#' res <- KmeansQuick(x$features$initial$x, K=3)
#' new.labels <- formatLabelSample(res$cluster, x)
#'
#' visualizeSampleClustering(x, label = new.labels, clustering.name="K-means",
#' profile.mode="whole sample")
#'
#' @export
#'
visualizeSampleClustering<- function(data.sample, label=NULL, clustering.name="proposed clustering",
cluster.summary=NULL, RclusTool.env=initParameters(),
prototypes=NULL, profile.mode="none",
selection.mode="none", compare.mode="off",
pairs=NULL, features.mode="initial",
wait.close=FALSE, fontsize=9){
#----------------------------------------------------------------------------------------
# Variables of the function
#----------------------------------------------------------------------------------------
visu.env <- new.env()
visu.env$plot.mode <- "scatter-plot"
visu.env$plotSampleFunction <- function(compare){} #function called by plotSample
visu.env$parH <- NULL
visu.env$parV <- NULL
visu.env$parPlotSampleFeatures <- NULL
visu.env$previous.clustering.name <- NULL
visu.env$label <- label
visu.env$cluster.summary <- cluster.summary
visu.env$clustering.name <- clustering.name
visu.env$data.sample <- data.sample
visu.env$prototypes <- NULL
visu.env$profile.mode <- profile.mode
visu.env$slider.values <- NULL #ids of subset of particles dealt with (may be a cluster, or prototypes)
visu.env$pts.search.tree <- NULL #search tree to locate mouse-selected points in scatter plot
visu.env$profile.id <- c(
sel=NA, #profile selected (in the top) id relative to described particles (by features$x)
mem=NA, #profile memorized (in the bottom)
fig=NA) #profile plotted (not always the one selected)
visu.env$mem.mode <- FALSE
visu.env$pairs.values <- NULL
visu.env$pairs.constraints <- NULL
visu.env$plot.height <- c() #graphic parameter : height of plot part (left)
visu.env$features.mode <- features.mode
visu.env$features <- NULL
visu.env$tcl.proto.label <- tclVar("")
visu.env$box.pixel <- NULL #plot bounding box in unit pixel
visu.env$compare.mode <- compare.mode
visu.env$summary.feat.select <- NULL
visu.env$summary.fun.select <- NULL
visu.env$summary.feature <- NULL # = couple feat + fun
visu.env$onScatterPlotMove <- function(x,y){}
visu.env$ProfileModeNumber <- 1
visu.env$tk.font <- tkfont.create(size = fontsize, family = "Arial", weight = "bold")
if (fontsize>=11){
visu.env$cex=0.8
} else if (fontsize>=9) {
visu.env$cex=0.7
} else {
visu.env$cex=0.6
}
if (!is.null(visu.env$label))
{
# case : new label to add
visu.env$label <- formatLabelSample(visu.env$label[visu.env$data.sample$id.clean], visu.env$data.sample, new.labels=FALSE, noise.cluster=RclusTool.env$param$preprocess$noise.cluster)
if (is.null(visu.env$cluster.summary))
visu.env$cluster.summary <- clusterSummary(visu.env$data.sample, visu.env$label, summary.functions=RclusTool.env$param$analysis$summary.functions)
visu.env$data.sample$clustering <- addClustering(clustering=visu.env$data.sample$clustering, new.clustering.name=visu.env$clustering.name,
new.cluster.summary=visu.env$cluster.summary, new.label=visu.env$label)
}
if (!is.null(visu.env$data.sample$clustering[[visu.env$clustering.name]]))
{
# case: data.sample contains the clustering named
visu.env$label <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$label
visu.env$cluster.summary <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary
} else {
if (is.null(visu.env$label)) {
# case: clustering named doesn't exist and no clustering proposed
visu.env$clustering.name <- "no-clustering"
visu.env$label <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$label
visu.env$cluster.summary <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary
}
}
visu.env$prototypes <- sapply(visu.env$data.sample$clustering, function(x) x$prototypes)
if (is.null(visu.env$prototypes[[visu.env$clustering.name]]))
{
if (!is.null(visu.env$data.sample$clustering[[visu.env$clustering.name]]$prototypes)) {
visu.env$prototypes[[visu.env$clustering.name]] <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$prototypes
} else {
visu.env$prototypes[[visu.env$clustering.name]] <- c()
}
visu.env$prototypes[[visu.env$clustering.name]] <- as.character(visu.env$label[names(visu.env$prototypes[[visu.env$clustering.name]])])
}
###MODIF
# prototypes$id <- visu.env$data.sample$id.abs.inv[prototypes$id.abs] #id: in sample not cleaned
# prototypes$label <- as.character(visu.env$label[prototypes$id])
# prototypes$id.abs.inv <- rep(NA, max(visu.env$data.sample$id.abs))
# prototypes$id.abs.inv[prototypes$id.abs] <- 1:length(prototypes$label) #id: in prototypes
#
if (length(grep("prototype", visu.env$profile.mode, ignore.case=TRUE))&&(!length(visu.env$prototypes)))
visu.env$profile.mode <- "none"
if (is.null(pairs)) {
visu.env$pairs.values <- list() #list of pairs (vector of 2 particle ids)
visu.env$pairs.constraints <- c() #how pair are constrained (+1 for ML, -1 for CNL)
} else {
visu.env$pairs.values <- c(pairs$ML, pairs$CNL)
visu.env$pairs.constraints <- c(rep(1,length(pairs$ML)), rep(-1, length(pairs$CNL)))
}
color.select <- c(grDevices::gray(0.25),grDevices::gray(0.90)) #color to plot selected particles points
if (!(visu.env$features.mode %in% names(visu.env$data.sample$features)))
visu.env$features.mode <- names(visu.env$data.sample$features)[1]
visu.env$features <- visu.env$data.sample$features[[visu.env$features.mode]]
visu.env$features$x <- visu.env$features$x[sapply(visu.env$features$x, is.numeric)]
signals <- visu.env$data.sample$profiles
images <- visu.env$data.sample$images
tcl.plot.mode <- tclVar(visu.env$plot.mode)
tcl.clustering.mode <- tclVar(visu.env$clustering.name)
tcl.features.mode <- tclVar(visu.env$features.mode)
tcl.profile.mode <- tclVar(visu.env$profile.mode) #"none", "whole sample", ou "cluster 'i'"
tcl.compare.mode <- tclVar(visu.env$compare.mode)
tcl.slider.big <- tclVar("0")
tcl.slider.tune <- tclVar("1")
slider.max <- 300 #maximal incrementations of slider.tune
#if (is.null(visu.env$cluster.summary))
#visu.env$cluster.summary <- clusterSummary(visu.env$data.sample, visu.env$label, summary.functions=RclusTool.env$param$analysis$summary.functions)
initClusterSummaryFeature <- function()
{
old.feature <- visu.env$summary.feature
summary.feats <- extractFeaturesFromSummary(visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary)
if (!length(summary.feats$simple))
stop("sampleView, visualizeSampleClustering: no simple features in the summary")
cluster.summary.simple.features <- paste("Result", summary.feats$simple.feats)
if (is.null(old.feature)|| !(old.feature %in% cluster.summary.simple.features))
visu.env$summary.feature <- cluster.summary.simple.features[1]
}
initClusterSummaryFeature()
cluster.summary.init <- visu.env$cluster.summary
#----------------------------------------------------------------------------------------
# functions to deal with ids of selected particles
#----------------------------------------------------------------------------------------
# not for profile.mode=="constrained pairs"
setProfileId <- function(names, value){
isna <- is.na(value)||!is.element(value, visu.env$slider.values)#is.na(visu.env$features$ids.inv[value])
if (isna)
value <- visu.env$slider.values[1]
for (name in names) {
visu.env$profile.id[name] <- value
}
if (is.element("sel", names))
setSlidersId(value, value=TRUE)
if ((is.element("mem", names))&&isna)
setMemMode(FALSE)
updateProfilesPlot(names)
}
# pair : a pair from slider.value
setProfileIdsPair <- function(pair){
names <- c("fig", "mem", "sel")
pair <- unlist(pair)
if (any(is.na(visu.env$features$x[pair,1]))) #(any(is.na(features$id.abs.inv[pair]))) ????
pair <- unlist(visu.env$slider.values[1])
for (name in names) {
val <- switch(name, fig=pair[1], sel=pair[1], mem=pair[2])
visu.env$profile.id[name] <- val
}
# if (is.element("sel", names))
# setSlidersId(value, value=TRUE)
updateProfilesPlot(names)
}
updateProfileId <- function(names=c("fig","mem","sel")){
for (name in names) {
setProfileId(name, visu.env$profile.id[name])#test
}
}
#----------------------------------------------------------------------------------------
# plot functions of the sample (left area)
#----------------------------------------------------------------------------------------
plotSample <- function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg="white")
visu.env$plotSampleFunction(compare=FALSE)
}
plotSampleCompare <- function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg="white")
visu.env$plotSampleFunction(compare=TRUE)
}
plotScatter <- function(compare=FALSE){
label <- visu.env$features$label
clustering.name <- visu.env$clustering.name
if (compare) {
clustering.name <- visu.env$previous.clustering.name
label <- visu.env$data.sample$clustering[[clustering.name]]$label[rownames(visu.env$features$x)]
}
x <- visu.env$features$x.2D.logscale
logscale <- visu.env$features$logscale.2D
title <- paste(visu.env$plot.mode, "clustered by", clustering.name)
plotSampleFeatures(x, label, parH=visu.env$parH, parV=visu.env$parV, figure.title=title,
logscale=logscale, cex=visu.env$cex, point.param=RclusTool.env$param$visu$point.style, env.plot=visu.env)
if (is.null(visu.env$parPlotSampleFeatures))
return()
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
par(visu.env$parPlotSampleFeatures)
#ids <- visu.env$features$id.abs.inv[c(visu.env$profile.id$sel, visu.env$profile.id$mem)]
#names(ids) <- c("sel", "mem")
ids <- visu.env$profile.id[c("sel", "mem")]
# add links
if (visu.env$profile.mode=="constrained pairs") {
selected.pair.id <- getSlidersValue(value=FALSE)
for (i in 1:length(visu.env$slider.values)) {
if (i==selected.pair.id)
next
pair <- visu.env$pairs.values[[i]]
w <- pair #features$id.abs.inv[pair]
#if (any(is.na(w)))
if (any(is.na(x[w,])))
next
if (visu.env$pairs.constraints[i]==1) {
graphics::points(x[w,], type="l", col="darkgreen", lwd=2)
}
if (visu.env$pairs.constraints[i]==-1) {
graphics::points(x[w,], type="l", col="darkred", lwd=2)
}
}
if (!any(is.na(ids))) {###A verifier
if (visu.env$pairs.constraints[selected.pair.id]==1) {
graphics::points(x[ids,], type="l", col="darkgreen", lwd=4)
}
if (visu.env$pairs.constraints[selected.pair.id]==-1) {
graphics::points(x[ids,], type="l", col="darkred", lwd=4)
}
}
}
# add point whose profile is plotted
#colored cross + circle + point on selected point(s)
if ((visu.env$profile.mode!="none") && (!(is.na(ids["sel"]))))
graphics::points(x[rep(ids["sel"],3),,drop=FALSE],
pch=c("+", "O", RclusTool.env$param$visu$point.style$pch[unclass(label[ids["sel"]])]),
cex=c(2, 2, RclusTool.env$param$visu$cex),
col=c(color.select[1:2], RclusTool.env$param$visu$point.style$col[unclass(label[ids["sel"]])]))
if ((visu.env$mem.mode) && (!(is.na(ids["mem"]))))
graphics::points(x[rep(ids["mem"],3),,drop=FALSE],
pch=c("+", "O", RclusTool.env$param$visu$point.style$pch[unclass(label[ids["mem"]])]),
cex=c(2, 2, RclusTool.env$param$visu$cex),
col=c(color.select[1:2], RclusTool.env$param$visu$point.style$col[unclass(label[ids["mem"]])]))
parPlotSize <- par("plt")
width <- as.numeric(tclvalue(tkwinfo("reqwidth", tk.plot.fig)))
height <- as.numeric(tclvalue(tkwinfo("reqheight", tk.plot.fig)))
usrCoords <- par("usr")
width <- as.numeric(tclvalue(tkwinfo("reqwidth", tk.plot.fig)))
xMin <- parPlotSize[1] * width
xMax <- parPlotSize[2] * width
yMin <- parPlotSize[3] * height
yMax <- parPlotSize[4] * height
rangeX <- usrCoords[2] - usrCoords[1]
rangeY <- usrCoords[4] - usrCoords[3]
visu.env$plot.height <- height
# A VERIFIER
visu.env$features$x.2D.pixel <- cbind((visu.env$features$x.2D[,1]-usrCoords[1])*(xMax-xMin)/rangeX + xMin,
(visu.env$features$x.2D[,2]-usrCoords[3])*(yMax-yMin)/rangeY + yMin )
rownames(visu.env$features$x.2D.pixel) <- rownames(visu.env$features$x.2D)
visu.env$box.pixel <- c(xMin, xMax, yMin, yMax)
visu.env$usrCoords <- usrCoords
# if new plot, then search tree is rebuilt
if (is.null(visu.env$pts.search.tree))
buildPtsSearchTree()
}
plotDensity2Dcall <- function(compare=FALSE){
if (!compare) {
label <- visu.env$label
clustering.name <- visu.env$clustering.name
} else {
clustering.name <- visu.env$previous.clustering.name
label <- visu.env$data.sample$clustering[[clustering.name]]$label
}
if (is.null(visu.env$parH)) {
visu.env$parH <- colnames(data.sample$features[[visu.env$features.mode]]$x)[1]
}
cluster.density <- clusterDensity(data.sample, label, visu.env$features.mode, features.to.keep=visu.env$parH)
plotDensity2D(cluster.density,parH=visu.env$parH, clustering.name=clustering.name, col= RclusTool.env$param$visu$palette.colors)
}
plotDensity1D <- function(compare=FALSE){
compare <- NULL
x <- visu.env$features$x.2D
xtick <- pretty(x[,1])
ytick <- pretty(x[,2])
logscale <- visu.env$features$logscale.2D
labx <- xtick
laby <- ytick
if (length(grep("x",logscale)))
labx <- 10^xtick
if (length(grep("y",logscale)))
laby <- 10^ytick
densite <- MASS::kde2d(x[,1], x[,2], n=100, h=.1)
densite$z <- log10( removeZeros(densite$z, threshold=10^-6, positive=TRUE) ) #echelle log...
graphics::filled.contour(densite, color = grDevices::topo.colors,
plot.axes = { graphics::axis(1, at=xtick, labels=labx);
graphics::axis(2, at=ytick, labels=laby) })
# points(x)
graphics::title(xlab=colnames(visu.env$features$x.2D)[1]) #paste(visu.env$parH[1], visu.env$parH[2], sep=" - "))
graphics::title(ylab=colnames(visu.env$features$x.2D)[2]) #paste(visu.env$parV[1], visu.env$parV[2], sep=" - "))
graphics::title(paste(visu.env$plot.mode, "(log)"), cex.main=visu.env$cex)
}
plotSummary <- function(compare=FALSE){
if (!compare) {
label <- visu.env$label
clustering.name <- visu.env$clustering.name
} else {
clustering.name <- visu.env$previous.clustering.name
label <- visu.env$data.sample$clustering[[clustering.name]]$label
}
cluster.summary <- visu.env$data.sample$clustering[[clustering.name]]$summary
title <- paste(visu.env$plot.mode, "clustered by", clustering.name)
feature.name.summary <- visu.env$summary.feature
m <- match(rownames(cluster.summary), levels(label))
col <- RclusTool.env$param$visu$point.style$col[m]
if (grepl("Result", feature.name.summary)) {
feature.name.summary <- sub("Result ", "", feature.name.summary)
cluster.factor <- factor(rownames(cluster.summary), levels = rownames(cluster.summary))
df=data.frame(values=cluster.summary[, feature.name.summary],cluster=cluster.factor)
p <- ggplot2::ggplot(data=df,aes(y=values,x=df$cluster,fill=df$cluster)) + geom_bar(stat="identity")
p <- p + ggplot2::xlab("") + ggplot2::ylab(feature.name.summary)
p <- p + ggplot2::ggtitle(title)
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::theme(axis.text.x = element_text(angle = 90, size=11))
p <- p + ggplot2::scale_fill_manual(values=col, drop=FALSE)
p <- p + ggplot2::theme(legend.position='none')
p <- p + ggplot2::theme(axis.text.x = element_text(size = RclusTool.env$param$visu$size))
p <- p + ggplot2::theme(axis.text.y = element_text(size = RclusTool.env$param$visu$size))
p <- p + ggplot2::theme(plot.title = element_text(size = RclusTool.env$param$visu$size))
print(p)
} else {
graphics::boxplot(visu.env$data.sample$features[[visu.env$features.mode]]$x[visu.env$data.sample$id.clean,feature.name.summary]~
label[visu.env$data.sample$id.clean],
names=levels(label),
las=3, col=RclusTool.env$param$visu$point.style$col, border=RclusTool.env$param$visu$point.style$col, outline = FALSE,
main=title,
ylab=feature.name.summary)
}
}
# function linked to tk.plot.frame
OnPlotSample <- function() {
tkrreplot.RclusTool(tk.plot.fig)
if (visu.env$compare.mode=="on"){
tkrreplot.RclusTool(tk.plot.compare.fig)
}
}
#----------------------------------------------------------------------------------------
# functions to deal with interactivity in Plot part (left)
#----------------------------------------------------------------------------------------
OnLeavePlot <- function() {
if (is.element(visu.env$profile.mode, c("none", "constrained pairs")))
return()
if (visu.env$profile.id["sel"] != visu.env$profile.id["fig"])
setProfileId("fig", visu.env$profile.id["sel"])
}
OnMouseMove <- function(x, y) {
if (is.element(visu.env$profile.mode, c("none", "constrained pairs")))
return()
if (is.null(visu.env$pts.search.tree))
return()
xClick <- as.numeric(x)+0.5
yClick <- as.numeric(y)-0.5
yClick <- visu.env$plot.height - yClick
if ( (xClick<visu.env$box.pixel[1])||(xClick>visu.env$box.pixel[2])||
(yClick<visu.env$box.pixel[3])||(yClick>visu.env$box.pixel[4]) ) {
OnLeavePlot()
return()
}
# coords <- 10^c(usrCoords[1]+(xClick-xMin)*rangeX/(xMax-xMin),
# usrCoords[3]+(yClick-yMin)*rangeY/(yMax-yMin))
if (!is.null(visu.env$pts.search.tree)) {
w <- as.character(visu.env$slider.values[SearchTrees::knnLookup(visu.env$pts.search.tree, xClick, yClick, k=1)[1]])
#w <- as.character(class::knn(visu.env$features$x.2D.pixel[visu.env$slider.values,,drop=FALSE],
# c(xClick, yClick), visu.env$slider.values)) #A VERIFIER !!
setProfileId("fig", w)
}
}
OnMovePlotFun <- function(x,y)
{
visu.env$onScatterPlotMove(x,y)
}
OnMouseClick <- function(x, y) {
if (is.element(visu.env$profile.mode, c("none", "constrained pairs")))
return()
OnMouseMove(x, y)
setProfileId("sel", visu.env$profile.id["fig"])
OnPlotSample()
}
#----------------------------------------------------------------------------------------
# plot functions of the profile(s) (right area)
#----------------------------------------------------------------------------------------
OnPlotProfile <- function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg="white")
if (is.na(visu.env$profile.id["fig"]))
return()
id <- visu.env$profile.id["fig"]
cluster <- NA
if ( (selection.mode=="prototypes") && length(visu.env$prototypes[[visu.env$clustering.name]])){
cluster <- visu.env$prototypes[[visu.env$clustering.name]][id]
}
if (is.na(cluster))
cluster <- visu.env$features$label[id]
if (is.null(visu.env$data.sample$config$signalColor)){
signalColor <- RclusTool.env$param$visu$palette.colors
} else {
signalColor <- visu.env$data.sample$config$signalColor
}
if (is.null(visu.env$data.sample$profiles)){
visu.env$ProfileModeNumber <- 2
}
title.color <- RclusTool.env$param$visu$palette.colors[unclass(cluster)]
if (visu.env$ProfileModeNumber == 1){
plotProfile(visu.env$data.sample$profiles[[id]], profiles.colors=signalColor,
NULL, title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=NULL ,charsize=fontsize)
} else if (visu.env$ProfileModeNumber == 2){
plotProfile(NULL, profiles.colors=signalColor,
visu.env$data.sample$images[id], title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=visu.env$data.sample$files$images, charsize=fontsize)
} else {
plotProfile(visu.env$data.sample$profiles[[id]], profiles.colors=signalColor,
visu.env$data.sample$images[id], title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=visu.env$data.sample$files$images, charsize=fontsize)
}
tkpack(tk.profile.fig, fill="x")
}
OnPlotProfile2 <- function(){
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg="white")
if (is.na(visu.env$profile.id["mem"]))
return()
id <- visu.env$profile.id["mem"]
cluster <- NA
if ( (selection.mode=="prototypes") && length(visu.env$prototypes[[visu.env$clustering.name]])){
cluster <- visu.env$prototypes[[visu.env$clustering.name]][id]
}
if (is.na(cluster))
cluster <- visu.env$features$label[id]
if (is.null(visu.env$data.sample$config$signalColor)){
signalColor <- RclusTool.env$param$visu$palette.colors
} else {
signalColor <- visu.env$data.sample$config$signalColor
}
if (is.null(visu.env$data.sample$profiles)){
visu.env$ProfileModeNumber <- 2
}
if (visu.env$mem.mode)
{
title.color <- RclusTool.env$param$visu$palette.colors[unclass(cluster)] #[unclass(label[id])] ??
if (visu.env$ProfileModeNumber == 1){
plotProfile(visu.env$data.sample$profiles[[id]], profiles.colors=signalColor,
NULL, title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=NULL , charsize=fontsize)
} else if (visu.env$ProfileModeNumber == 2){
plotProfile(NULL, profiles.colors=signalColor,
visu.env$data.sample$images[id], title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=visu.env$data.sample$files$images ,charsize=fontsize)
} else {
plotProfile(visu.env$data.sample$profiles[[id]], profiles.colors=signalColor,
visu.env$data.sample$images[id], title=paste("Observation", id),
sub=paste("in", cluster), sub.color=title.color, image.dir=visu.env$data.sample$files$images, charsize=fontsize)
}
tkpack(tk.profile.mem, fill="x")
} else
tkpack.forget(tk.profile.mem)
}
#----------------------------------------------------------------------------------------
# Menu functions
#----------------------------------------------------------------------------------------
OnModifPlotMode <- function() {
plot.mode.old <- visu.env$plot.mode
visu.env$plot.mode <- tclvalue(tcl.plot.mode)
visu.env$plotSampleFunction <- switch(visu.env$plot.mode,
"scatter-plot"=plotScatter,
"density-plot"=plotDensity1D,
"variables density by cluster"=plotDensity2Dcall,
"clusters summary"={
if (!is.null(visu.env$cluster.summary)){
plotSummary
} else {
visu.env$plot.mode <- plot.mode.old
tclvalue(tcl.plot.mode) <- visu.env$plot.mode
visu.env$plotSampleFunction
}
}
)
visu.env$onScatterPlotMove <- function(x,y){}
if (visu.env$plot.mode == "scatter-plot")
visu.env$onScatterPlotMove <- OnMouseMove
visibilityProfile() #hides/shows Profiles frame according to "cluster summary" mode or not
OnPlotSample()
}
OnModifFeaturesMode <- function() {
visu.env$features.mode <- tclvalue(tcl.features.mode)
tkdelete(tk.axis.menu, 0, "end")
visu.env$features <- visu.env$data.sample$features[[visu.env$features.mode]]
visu.env$features$x <- as.data.frame(visu.env$features$x)
if (visu.env$features.mode=="initial")
visu.env$features$x <- visu.env$features$x[sapply(visu.env$features$x,is.numeric)]
visu.env$features$label <- visu.env$label[rownames(visu.env$features$x)]
initAxis()
buildMenuInitialFeatures()
OnModifProfileMode()
}
# Transform parameters button
OnModifAxisH <- function() {OnModifAxisHV(Horizontal=TRUE)}
OnModifAxisV <- function() {OnModifAxisHV(Horizontal=FALSE)}
OnModifAxisHV <- function(Horizontal) {
feat.names <- colnames(visu.env$features$x)
if (!length(feat.names))
return()
if (Horizontal) {
axis.name <- "Horizontal"
feat.select <- visu.env$parH
} else {
axis.name <- "Vertical"
feat.select <- visu.env$parV
}
# Create new window for the parameter transformation
onmodiftt <- tktoplevel()
tktitle(onmodiftt) <- paste("Select", axis.name, "axis")
#Search the selected parameter
tkgrid(tk2label(onmodiftt, text = " "), row = 1, sticky = "w")
# First listbox with all parameters
feat.list <- tk2listbox(onmodiftt, selectmode = "single", activestyle = "dotbox",
height = 10, width = 27, autoscroll = "none", background = "white")
tkgrid(feat.list, row = 2, column = 0, rowspan = 4, sticky = "w")
# Close selection window operation
onClose <- function() {
tkdestroy(onmodiftt)
}
butClose <- tk2button(onmodiftt, text = "Close", width = -6, command = onClose)
tkgrid(butClose, row = 5, column=1, columnspan = 2)
for (feat in feat.names) {
tkinsert(feat.list, "end", feat)
}
OnFeatSelectH <- function()
{
visu.env$parH <- feat.names[as.numeric(tkcurselection(feat.list)) + 1]
modifAxisUpdate()
OnPlotSample()
buildMenuInitialFeatures()
}
OnFeatSelectV <- function()
{
visu.env$parV <- feat.names[as.numeric(tkcurselection(feat.list)) + 1]
modifAxisUpdate()
OnPlotSample()
buildMenuInitialFeatures()
}
# Initialize selection in the two listboxes
tkselection.set(feat.list, which(feat.names==feat.select)-1)
if (Horizontal) {
tkbind(feat.list, "<ButtonRelease-1>", OnFeatSelectH)
} else {
tkbind(feat.list, "<ButtonRelease-1>", OnFeatSelectV)
}
}
OnSimpleFeatSummary <- function(feat.name) {
tclvalue(tcl.plot.mode) <- "clusters summary"
visu.env$summary.feature <- paste("Result", feat.name)
OnModifPlotMode()
}
OnFeatFunSummary <- function() {
tclvalue(tcl.plot.mode) <- "clusters summary"
summary.names <- extractFeaturesFromSummary(visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary)
summary.names1 <- summary.names$feats
summary.names2 <- summary.names$funs
if (!length(summary.names1))
return()
if (!is.null(visu.env$summary.feat.select) && !is.null(visu.env$summary.fun.select)) {
summary.select1 <- visu.env$summary.feat.select
summary.select2 <- visu.env$summary.fun.select
} else {
summary.select1 <- summary.names1[1]
summary.select2 <- summary.names2[1]
}
# Create new window for the parameter transformation
onmodifcl <- tktoplevel()
tktitle(onmodifcl) <- paste("Select Cluster Summary")
#Search the selected parameter
tkgrid(tk2label(onmodifcl, text = " "), row = 1, sticky = "w")
# First listbox with all parameters
tkgrid(tk2label(onmodifcl, text = "Select the feature", justify = "left"),
row = 0, column = 0, sticky = "w")
summary.list1 <- tk2listbox(onmodifcl, selectmode = "single", activestyle = "dotbox",
height = 10, width = 27, autoscroll = "none", background = "white")
tkgrid(summary.list1, row = 1, column = 0, rowspan = 4, sticky = "w")
# Second listbox with all parameters
tkgrid(tk2label(onmodifcl, text = "Select the parameter", justify = "left"),
row = 0, column = 1, sticky = "w")
summary.list2 <- tk2listbox(onmodifcl, selectmode = "single", activestyle = "dotbox",
height = 10, width = 27, autoscroll = "none", background = "white")
tkgrid(summary.list2, row = 1, column = 1, rowspan = 4, sticky = "w")
# Close selection window operation
onClose <- function() {
tkdestroy(onmodifcl)
}
butClose <- tk2button(onmodifcl, text = "Close", width = -6, command = onClose)
tkgrid(butClose, row = 8, column=1, columnspan = 2)
for (summary1 in summary.names1) {
tkinsert(summary.list1, "end", summary1)
}
for (summary2 in summary.names2) {
tkinsert(summary.list2, "end", summary2)
}
onSummarySelect <- function()
{
visu.env$summary.feat.select <- summary.names1[as.numeric(tkcurselection(summary.list1)) + 1]
visu.env$summary.fun.select <- summary.names2[as.numeric(tkcurselection(summary.list2)) + 1]
value1 <- paste("Result", visu.env$summary.feat.select)
visu.env$summary.feature <- paste(value1, visu.env$summary.fun.select, sep="...")
OnModifPlotMode()
}
# Initialize selection in the two listboxes
tkselection.set(summary.list1, which(summary.names1==summary.select1)-1)
tkselection.set(summary.list2, which(summary.names2==summary.select2)-1)
tkbind(summary.list1, "<ButtonRelease-1>", onSummarySelect)
tkbind(summary.list2, "<ButtonRelease-1>", onSummarySelect)
}
modifAxisUpdate <- function() {
visu.env$features$x.2D <- visu.env$features$x[, c(visu.env$parH, visu.env$parV), drop=FALSE]
visu.env$features$x.2D.logscale <- visu.env$features$x.2D #representation for plot functions with log scale
logscale <- ""
if (visu.env$features$logscale[visu.env$parH]) {
logscale <- "x"
visu.env$features$x.2D.logscale[,1] <- 10^visu.env$features$x.2D[,1]
}
if (visu.env$features$logscale[visu.env$parV]) {
logscale <- paste(logscale, "y", sep="")
visu.env$features$x.2D.logscale[,2] <- 10^visu.env$features$x.2D[,2]
}
visu.env$features$logscale.2D <- logscale
# force rebuilding of the search tree
visu.env$pts.search.tree <- NULL
}
#without plotSample
initAxis <- function() {
pref.features <- NULL
#if (visu.env$features.mode == "initial")
# pref.features must be in colnames(features$x)!
# (if preprocessed data, with "log" suffix...)
# pref.features <- colnames(features$x)[grep(paste(visu.env$data.sample$config$defaultFeat, collapse = "|"), colnames(features$x))] #regular expression
pref.features <- intersect(visu.env$data.sample$config$defaultFeat, colnames(visu.env$features$x))
if (!is.null(pref.features) & (length(pref.features)>=2))
names(pref.features)[1:2] <- c("parH","parV")
#pref.features <- visu.env$data.sample$config$defaultFeat
if ( is.null(pref.features) || (length(pref.features)<2)
|| !any(colnames(visu.env$features$x)==pref.features["parH"])
|| !any(colnames(visu.env$features$x)==pref.features["parV"]) )
pref.features <- colnames(visu.env$features$x)[1:2]
visu.env$parH <- pref.features[1]
visu.env$parV <- pref.features[2]
modifAxisUpdate()
}
visibilityProfile <- function()
{
# hide profiles
if (visu.env$plot.mode != "scatter-plot")
{
tkpack.forget(tk.profile.frame)
return()
}
if (visu.env$profile.mode=="none") {
tkpack.forget(tk.profile.frame)
return()
}
tkpack(tk.profile.frame, side="left")
}
OnModifProfileMode <- function() {
new.mode <- tclvalue(tcl.profile.mode)
tkpack.forget(tk.profile.frame)
# if new mode not possible
if (!length(visu.env$prototypes) && ((new.mode=="prototypes"))){
tclvalue(tcl.profile.mode) <- visu.env$profile.mode
return()
}
if (!length(visu.env$pairs.values) && ((new.mode=="constrained pairs"))){
tclvalue(tcl.profile.mode) <- visu.env$profile.mode
return()
}
visu.env$profile.mode <- new.mode
# select particles able to be selected -> visu.env$slider.values
switch(visu.env$profile.mode,
"none"=c(),
"whole sample"=sortCharAsNum(rownames(visu.env$features$x)),
"items with signal(s)"=sortCharAsNum(rownames(signals)),
"items with image(s)"=sortCharAsNum(names(images)),
"prototypes"= names(visu.env$prototypes[[visu.env$clustering.name]][order(visu.env$prototypes[[visu.env$clustering.name]])]),
"constrained pairs"=visu.env$pairs.values,
{ #default
cluster.num <- tclvalue(tcl.profile.mode)
sortCharAsNum(rownames(visu.env$features$x)[visu.env$features$label==cluster.num])
}
) -> values
# if no particles can be selected : go back
if (!length(values)){
visu.env$profile.mode <- "none"
tclvalue(tcl.profile.mode) <- visu.env$profile.mode
OnPlotSample()
return()
}
configureSliders(values) #settings BEFORE positioning !
buildPtsSearchTree()
if (visu.env$profile.mode=="constrained pairs") {
setMemMode(TRUE)
OnSliderMove()
} else{
updateProfileId()
}
if (visu.env$profile.mode=="none")
setMemMode(FALSE)
OnPlotSample()
tkpack(tk.profile.frame, side="left")
}
#----------------------------------------------------------------------------------------
# Slider functions
#----------------------------------------------------------------------------------------
setSlidersId <- function(id, value=FALSE) {
if (value)
id <- match(id, visu.env$slider.values)
slider.tune.max <- min(slider.max, length(visu.env$slider.values))
val.big <- floor((id-1)/slider.tune.max)*slider.tune.max
val.tune <- id - val.big
tclvalue(tcl.slider.big) <- as.integer(val.big)
tclvalue(tcl.slider.tune) <- as.integer(val.tune)
}
getSlidersValue <- function(value=TRUE) {
if (tclvalue(tcl.slider.tune)=="0")
tclvalue(tcl.slider.tune) <- 1
id <- as.integer(tclvalue(tcl.slider.big)) + as.integer(tclvalue(tcl.slider.tune))
if (id > length(visu.env$slider.values)) {
tclvalue(tcl.slider.tune) <- length(visu.env$slider.values) - as.integer(tclvalue(tcl.slider.big))
id <- length(visu.env$slider.values)
}
switch(value+1, id, visu.env$slider.values[id])
}
buildPtsSearchTree <- function()
{
#search tree not useful => not computed
if (is.element(visu.env$profile.mode, c("none", "constrained pairs")))
return()
#data required
if (is.null(visu.env$features$x.2D.pixel) || !length(visu.env$slider.values))
return()
visu.env$pts.search.tree <- SearchTrees::createTree(visu.env$features$x.2D.pixel[visu.env$slider.values,,drop=FALSE])
}
configureSliders <- function(values, reset=TRUE){
visu.env$slider.values <- values
slider.tune.max <- min(slider.max, length(visu.env$slider.values))
slider.big.max <- (ceiling((length(visu.env$slider.values))/slider.tune.max)-1)*slider.tune.max
tkconfigure(tk.slider.big, from=0, to=slider.big.max, res=slider.tune.max)
tkconfigure(tk.slider.big.label, text=paste("big tuning\n(step = ", slider.tune.max, ")", sep=""))
tkconfigure(tk.slider.tune, from=1, to=slider.tune.max, res=1)
tkconfigure(tk.slider.tune.label, text=paste("fine tuning\n(from 1 to ", slider.tune.max,")", sep=""))
if (!reset) {
setSlidersId( getSlidersValue(value=FALSE), value=FALSE)
} else {
tclvalue(tcl.slider.big) <- 0
tclvalue(tcl.slider.tune) <- 1
}
}
#binded to tk.slider... Warning : button release dealt by OnPlotSample
#updates profile.*.id and plot profiles
OnSliderMove <- function(...) {
if (visu.env$profile.mode=="constrained pairs") {
setProfileIdsPair(getSlidersValue())
OnPlotSample()
} else {
setProfileId("sel", getSlidersValue())
setProfileId("fig", getSlidersValue())
}
}
updateProfilesPlot <- function(names=c("fig","mem")) {
if (is.element("fig", names))
tkrreplot(tk.profile.fig)
if (is.element("mem", names))
tkrreplot(tk.profile.mem)
if (visu.env$mem.mode) {
pair.status <- ""
pair <- c(visu.env$profile.id["sel"], visu.env$profile.id["mem"])
w <- which.pair(pair, visu.env$pairs.values)
if (!is.null(w))
pair.status <- switch(2+visu.env$pairs.constraints[w], "CNL","", "ML")
tkconfigure(tk.pairs.label, text=paste(pair.status, "Pair", paste(pair,
collapse=",")))
}
if (selection.mode=="prototypes"){
w <- visu.env$profile.id["sel"]
if (!is.na(w))
{
cluster <- NA
if (length(visu.env$prototypes[[visu.env$clustering.name]]))
cluster <- visu.env$prototypes[[visu.env$clustering.name]][w]
if (is.na(cluster))
cluster <- as.character(visu.env$features$label[w])
tclvalue(visu.env$tcl.proto.label) <- cluster
}
}
}
#----------------------------------------------------------------------------------------
# Pairs functions
#----------------------------------------------------------------------------------------
setMemMode <-function(bool) {
visu.env$mem.mode <- bool
if (!visu.env$mem.mode) {
tkpack.forget(tk.profile.mem)
} else
tkpack(tk.profile.mem, fill="x")
}
OnMemHide <- function() {
setMemMode(FALSE)
OnPlotSample()
}
ChangeProfileMode <- function() {
if (visu.env$ProfileModeNumber < 3){
visu.env$ProfileModeNumber <- visu.env$ProfileModeNumber + 1
} else {
visu.env$ProfileModeNumber <- 1
}
OnPlotProfile()
OnPlotProfile2()
}
OnMem <- function() {
setMemMode(TRUE)
setProfileId("mem", visu.env$profile.id["sel"])
OnPlotSample()
}
OnML <- function() {
if (!visu.env$mem.mode)
return() # message
pair <- c(visu.env$profile.id["sel"], visu.env$profile.id["mem"])
w <- which.pair(pair, visu.env$pairs.values)
if (is.null(w)){
visu.env$pairs.values <- c(visu.env$pairs.values, list(pair))
visu.env$pairs.constraints <- c(visu.env$pairs.constraints, +1)
} else
visu.env$pairs.constraints[w] <- +1
tkconfigure(tk.pairs.label, text=paste("ML", "Pair", paste(pair, collapse=",")))
OnPlotSample()
}
OnCNL <- function() {
if (!visu.env$mem.mode)
return() # message
pair <- c(visu.env$profile.id["sel"], visu.env$profile.id["mem"])
w <- which.pair(pair, visu.env$pairs.values)
if (is.null(w)){
visu.env$pairs.values <- c(visu.env$pairs.values, list(pair))
visu.env$pairs.constraints <- c(visu.env$pairs.constraints, -1)
} else
visu.env$pairs.constraints[w] <- -1
tkconfigure(tk.pairs.label, text=paste("CNL", "Pair", paste(pair, collapse=",")))
OnPlotSample()
}
OnCancelPair <- function() {
if (!visu.env$mem.mode)
return() # message
pair <- c(visu.env$profile.id["sel"], visu.env$profile.id["mem"])
w <- which.pair(pair, visu.env$pairs.values)
if (!is.null(w)){
visu.env$pairs.values <- visu.env$pairs.values[-w]
visu.env$pairs.constraints <- visu.env$pairs.constraints[-w]
}
tkconfigure(tk.pairs.label, text=paste("Pair", paste(pair, collapse=",")))
if (visu.env$profile.mode=="constrained pairs"){
if (!length(visu.env$pairs.values)) {
tclvalue(tcl.profile.mode) <- "none"
OnModifProfileMode()
} else {
configureSliders(visu.env$pairs.values, reset=FALSE) #settings BEFORE positioning !
OnSliderMove()
OnPlotSample()
}
}
}
OnValidPairs <- function() {
tkdestroy(tt)
}
which.pair <- function(pair, list.of.pairs) {
is.equal <- sapply(list.of.pairs, function(x) length(intersect(x, pair))==2)
if (!length(is.equal))
return()
res <- which(is.equal)
if (!length(res))
return()
res
}
#----------------------------------------------------------------------------------------
# Prototypes functions
#----------------------------------------------------------------------------------------
OnRenameCluster <- function() {
id <- visu.env$profile.id["sel"]
if (!nchar(tclvalue(visu.env$tcl.proto.label))) {
tclvalue(visu.env$tcl.proto.label) <- as.character(visu.env$label[id])
}
if (!is.na(id)){ ###A verifier
levels(visu.env$label)[which(levels(visu.env$label)==visu.env$label[id])] <- tclvalue(visu.env$tcl.proto.label)
visu.env$data.sample$clustering[[visu.env$clustering.name]]$label <- visu.env$label
}
buildMenuClustering()
buildMenuProfileMode()
OnModifProfileMode()
OnModifFeaturesMode()
OnPlotSample()
updateProfilesPlot()
}
OnSelectProto <- function() {
id <- visu.env$profile.id["sel"]
if (!nchar(tclvalue(visu.env$tcl.proto.label))) {
tclvalue(visu.env$tcl.proto.label) <- as.character(visu.env$label[id])
}
if (is.na(id)){ ###A verifier
visu.env$prototypes[[visu.env$clustering.name]] <- c(visu.env$prototypes[[visu.env$clustering.name]], tclvalue(visu.env$tcl.proto.label))
names(visu.env$prototypes[[visu.env$clustering.name]])[length(visu.env$prototypes[[visu.env$clustering.name]])] <- id
} else {
visu.env$prototypes[[visu.env$clustering.name]][id] <- tclvalue(visu.env$tcl.proto.label)
levels(visu.env$label)[which(levels(visu.env$label)==visu.env$label[id])] <- tclvalue(visu.env$tcl.proto.label)
visu.env$data.sample$clustering[[visu.env$clustering.name]]$label <- visu.env$label
}
buildMenuClustering()
buildMenuProfileMode()
OnModifProfileMode()
OnModifFeaturesMode()
OnPlotSample()
updateProfilesPlot()
}
OnCancelProto <- function() {
id <- visu.env$profile.id["sel"]
if (!is.na(id)){
visu.env$prototypes[[visu.env$clustering.name]] <- visu.env$prototypes[[visu.env$clustering.name]][names(visu.env$prototypes[[visu.env$clustering.name]]) != id]
if (visu.env$profile.mode=="prototypes"){
if (!length(visu.env$prototypes)) {
tclvalue(tcl.profile.mode) <- "none"
OnModifProfileMode()
} else {
configureSliders(names(visu.env$prototypes[[visu.env$clustering.name]][order(visu.env$prototypes[[visu.env$clustering.name]]$label)]), reset=FALSE) #settings BEFORE positioning !
OnSliderMove()
}
OnPlotSample()
}
updateProfilesPlot()
}
}
OnLeaveProto <- function() {
id <- visu.env$profile.id["sel"]
if (!is.na(id) && nchar(tclvalue(visu.env$tcl.proto.label))&&(!is.na(visu.env$prototypes[[visu.env$clustering.name]][id]))){
#prototypes[w] <- tclvalue(visu.env$tcl.proto.label)
visu.env$prototypes[[visu.env$clustering.name]][id] <- tclvalue(visu.env$tcl.proto.label)
updateProfilesPlot()
}
}
#----------------------------------------------------------------------------------------
# File clustering functions
#----------------------------------------------------------------------------------------
OnModifClusteringMode <- function() {
visu.env$previous.clustering.name <- visu.env$clustering.name
visu.env$clustering.name <- tclvalue(tcl.clustering.mode)
if (visu.env$clustering.name=="import clustering"){
filename.csv <- tclvalue(tkgetOpenFile(initialfile = "",
filetypes="{{csv Files} {.csv .CSV}}"))
res <- buildClusteringSample(filename.csv, visu.env$data.sample, RclusTool.env$param$preprocess$noise.cluster)
if ( !is.null(res) ) {
visu.env$clustering.name <- basename(filename.csv)
visu.env$data.sample$clustering[[visu.env$clustering.name]] <- res
visu.env$data.sample$clustering <-
c(visu.env$data.sample$clustering[-which(names(visu.env$data.sample$clustering)==visu.env$clustering.name)],
visu.env$data.sample$clustering[visu.env$clustering.name])
} else {
visu.env$clustering.name <- names(visu.env$data.sample$clustering[1])
}
}
tclvalue(tcl.clustering.mode) <- visu.env$clustering.name
visu.env$label <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$label
visu.env$cluster.summary <- visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary
if (visu.env$previous.clustering.name!=visu.env$clustering.name)
visu.env$previous.clustering.name <- visu.env$previous.clustering.name
buildMenuClustering()
buildMenuProfileMode()
OnModifProfileMode()
OnModifFeaturesMode()
OnModifPlotMode()
}
OnModifCompareMode <- function() {
visu.env$compare.mode <- tclvalue(tcl.compare.mode)
if (is.null(visu.env$previous.clustering.name) || (visu.env$previous.clustering.name == visu.env$clustering.name)) {
visu.env$compare.mode <- "off"
tclvalue(tcl.compare.mode) <- visu.env$compare.mode
return()
}
if (visu.env$compare.mode=="off") {
tkpack.forget(tk.plot.compare.frame)
} else {
if (visu.env$compare.mode=="comparison measure") {
warning("Function not implemented yet.")
#compareClusterings(visu.env$data.sample, c(visu.env$clustering.name, visu.env$previous.clustering.name))
visu.env$compare.mode <- "on" # env assignment should be better.
tclvalue(tcl.compare.mode) <- visu.env$compare.mode
}
tkpack(tk.plot.compare.frame, side="left", anchor="n")
OnPlotSample()
}
}
OnExportClustering <- function() {
filename.init <- paste("clustering ", RclusTool.env$gui$user.name, " ",
visu.env$clustering.name, ".csv", sep="")
rep.init <- visu.env$data.sample$files$results$clustering
params <- list(initialfile = filename.init, initialdir = rep.init,
filetypes="{{csv Files} {.csv .CSV}}")
if (!length(rep.init))
params$initialdir <- NULL
filename.csv <- tclvalue(do.call(tkgetSaveFile, params))
rep.final <- substr(filename.csv, 1, (nchar(filename.csv)-nchar(basename(filename.csv)))-1)
# saveClustering(filename.csv, label=visu.env$label, id.abs=rownames(visu.env$data.sample$features[[1]]$x))
saveClustering(filename.init, label=visu.env$label, dir=rep.final)
visu.env$data.sample$clustering[[visu.env$clustering.name]] <- buildClusteringSample(filename.csv, visu.env$data.sample, RclusTool.env$param$preprocess$noise.cluster)
}
OnExportSummary <- function() {
if (is.null(visu.env$cluster.summary)) {
tkmessageBox(message="First, select a clustering.")
return()
}
filename.init <- paste(visu.env$data.sample$name, " summary ", RclusTool.env$gui$user.name, " ",
visu.env$clustering.name, ".csv", sep="")
rep.init <- visu.env$data.sample$files$results$clustering
params <- list(initialfile = filename.init, initialdir = rep.init,
filetypes="{{csv Files} {.csv .CSV}}")
if (!length(rep.init))
params$initialdir <- NULL
filename.csv <- tclvalue(do.call(tkgetSaveFile, params))
rep.final <- substr(filename.csv, 1, (nchar(filename.csv)-nchar(basename(filename.csv)))-1)
# saveSummary(filename.csv=filename.csv, cluster.summary=visu.env$cluster.summary,
# data.sample=visu.env$data.sample, operator.name=RclusTool.env$gui$user.name, method.name=visu.env$clustering.name)
saveSummary(filename.csv=filename.init, cluster.summary=visu.env$cluster.summary, dir=rep.final)
}
# OnCountItems <- function() {
# if (is.character(visu.env$data.sample$files$images)) {
# #dev.off()
# countItemsSampleGUI(visu.env$data.sample, RclusTool.env=RclusTool.env)
# } else
# tkmessageBox(message = "No images to process!", icon = "warning", type = "ok")
# }
#
# OnApplyItems <- function() {
# computeItemsSampleGUI(visu.env$data.sample, method.select = visu.env$clustering.name, RclusTool.env=RclusTool.env)
# }
#----------------------------------------------------------------------------------------
# GUI
#----------------------------------------------------------------------------------------
tt <- tktoplevel(bg="white");
tkwm.title(tt,"Sample visualization")
# tkwm.geometry(tt,"670x680+0+0")
#--------------------
#definition of menus
#--------------------
buildMenuInitialFeatures <- function() {
tkdelete(tk.axis.menu, 0, "end")
tkadd(tk.axis.menu, "command", label=paste("H-axis:",visu.env$parH), command=cat)
tkadd(tk.axis.menu, "command", label=paste("V-axis:",visu.env$parV), command=cat)
tkadd(tk.axis.menu, "command", label="Modify H-axis", command=OnModifAxisH)
tkadd(tk.axis.menu, "command", label="Modify V-axis", command=OnModifAxisV)
}
buildMenuProfileMode <- function() {
tkdelete(tk.profile.mode.menu, 0, "end")
tkadd(tk.profile.mode.menu, "radio", label="none", variable=tcl.profile.mode,
command=OnModifProfileMode)
tkadd(tk.profile.mode.menu, "radio", label="whole sample", variable=tcl.profile.mode,
command=OnModifProfileMode)
tkadd(tk.profile.mode.menu, "radio", label="items with signal(s)", variable=tcl.profile.mode,
command=OnModifProfileMode)
tkadd(tk.profile.mode.menu, "radio", label="items with image(s)", variable=tcl.profile.mode,
command=OnModifProfileMode)
# if (!is.null(prototype.ids))
tkadd(tk.profile.mode.menu, "radio", label="prototypes", variable=tcl.profile.mode,
command=OnModifProfileMode)
tkadd(tk.profile.mode.menu, "radio", label="constrained pairs", variable=tcl.profile.mode,
command=OnModifProfileMode)
for (lev in levels(visu.env$label))
tkadd(tk.profile.mode.menu, "radio", label=lev, variable=tcl.profile.mode,
command=OnModifProfileMode)
}
buildMenuSummary <- function(){
tkdelete(tk.summary.mode.menu, 0, "end")
summary.feats <- extractFeaturesFromSummary(visu.env$data.sample$clustering[[visu.env$clustering.name]]$summary)
if (!is.null(summary)){
for (s in summary.feats$simple.feats)
tkadd(tk.summary.mode.menu, "command", label=s, command=function(){ OnSimpleFeatSummary(s)})
tkadd(tk.summary.mode.menu, "command", label="Select Your Parameters", command=OnFeatFunSummary)
}
}
buildMenuClustering <- function() {
tkdelete(tk.clustering.menu, 0, "end")
tkadd(tk.clustering.menu, "radio", label="import clustering", variable=tcl.clustering.mode,
command=OnModifClusteringMode)
tkadd(tk.clustering.menu, "command", label="export clustering", command=OnExportClustering)
tkadd(tk.clustering.menu, "command", label="export summary", command=OnExportSummary)
# tkadd(tk.clustering.menu, "command", label="count items from images", command=OnCountItems)
# tkadd(tk.clustering.menu, "command", label="apply items counts models", command=OnApplyItems)
for (name in names(visu.env$data.sample$clustering))
tkadd(tk.clustering.menu, "radio", label=name, variable=tcl.clustering.mode,
command=OnModifClusteringMode)
}
tk.topmenu <- tkmenu(tt, tearoff=FALSE)
tkconfigure(tt, menu=tk.topmenu)
tkconfigure(tk.topmenu, font=visu.env$tk.font)
tk.plot.mode.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.plot.mode.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Plot type", menu=tk.plot.mode.menu)
tkadd(tk.plot.mode.menu, "radio", label="scatter-plot", variable=tcl.plot.mode,
value="scatter-plot", command=OnModifPlotMode)
tkadd(tk.plot.mode.menu, "radio", label="density-plot", variable=tcl.plot.mode,
value="density-plot", command=OnModifPlotMode)
tkadd(tk.plot.mode.menu, "radio", label="clusters summary", variable=tcl.plot.mode,
value="clusters summary", command=OnModifPlotMode)
tkadd(tk.plot.mode.menu, "radio", label="variables density by cluster", variable=tcl.plot.mode,
value="variables density by cluster", command=OnModifPlotMode)
tk.features.mode.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.features.mode.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Features space", menu=tk.features.mode.menu)
for (name in sortCharAsNum(names(visu.env$data.sample$features)))
tkadd(tk.features.mode.menu, "radio", label=featSpaceNameConvert(name, short2long=TRUE, RclusTool.env), variable=tcl.features.mode,
value=name, command=OnModifFeaturesMode)
tk.axis.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.axis.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Scatter Plot-axis", menu=tk.axis.menu)
if (!is.null(visu.env$cluster.summary)) {
tk.summary.mode.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.summary.mode.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Clusters summaries", menu=tk.summary.mode.menu)
buildMenuSummary()
}
tk.profile.mode.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.profile.mode.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Signals/Images view", menu=tk.profile.mode.menu)
tk.clustering.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.clustering.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Clustering", menu=tk.clustering.menu)
tk.compare.menu <- tkmenu(tk.topmenu, tearoff=FALSE)
tkconfigure(tk.compare.menu, font=visu.env$tk.font)
tkadd(tk.topmenu, "cascade", label="Comparison", menu=tk.compare.menu)
tkadd(tk.compare.menu, "radio", label="off", variable=tcl.compare.mode,
value="off", command=OnModifCompareMode)
tkadd(tk.compare.menu, "radio", label="on", variable=tcl.compare.mode,
value="on", command=OnModifCompareMode)
#tkadd(tk.compare.menu, "radio", label="comparison measure", variable=tcl.compare.mode,
# value="comparison measure", command=OnModifCompareMode)
buildMenuProfileMode()
buildMenuClustering()
#------------------
#frames and figures
#------------------
tk.plot.frame <- tkframe(tt, bg="white")
tk.profile.frame <- tkframe(tt, bg="white")
visu.env$plotSampleFunction <- function(...){plot(1)}
tk.plot.fig <- tkrplot.RclusTool(tk.plot.frame, fun=plotSample, hscale=RclusTool.env$param$visu$hscale+0.4, vscale=RclusTool.env$param$visu$hscale+0.2)
tkbind(tk.plot.fig, "<Motion>", OnMovePlotFun)
tkbind(tk.plot.fig, "<Button-1>", OnMouseClick)
tkbind(tk.plot.fig, "<Leave>", OnLeavePlot)
tk.plot.compare.frame <- tkframe(tt, bg="white")
tk.plot.compare.fig <- tkrplot.RclusTool(tk.plot.compare.frame, fun=plotSampleCompare, hscale=RclusTool.env$param$visu$hscale+0.4, vscale=RclusTool.env$param$visu$hscale+0.2)
tk.profile.fig <- tkrplot(tk.profile.frame, fun=OnPlotProfile, hscale=(RclusTool.env$param$visu$hscale)*RclusTool.env$param$visu$scale.graphics, vscale=0.6*RclusTool.env$param$visu$hscale*RclusTool.env$param$visu$scale.graphics)
tk.profile.mem <- tkrplot(tk.profile.frame, fun=OnPlotProfile2, hscale=(RclusTool.env$param$visu$hscale)*RclusTool.env$param$visu$scale.graphics, vscale=0.6*RclusTool.env$param$visu$hscale*RclusTool.env$param$visu$scale.graphics)
tk.slider.frame <- tkframe(tk.profile.frame, bg="white")
tk.slider.left.frame <- tkframe(tk.slider.frame, bg="white")
tk.slider.center.frame <- tkframe(tk.slider.frame, bg="white")
tk.slider.right.frame <- tkframe(tk.slider.frame, bg="white")
tk.slider.big <- tkscale(tk.slider.center.frame, length=450, bg="white",
command=OnSliderMove,
showvalue=TRUE, variable=tcl.slider.big, orient="horizontal")
tk.slider.tune <- tkscale(tk.slider.center.frame, length=450, bg="white",
command=OnSliderMove,
showvalue=TRUE, variable=tcl.slider.tune, orient="horizontal")
tk.slider.tune.label <- tklabel(tk.slider.right.frame, text="fine tuning", fg="black", bg="white", font=visu.env$tk.font)
tk.slider.big.label <- tklabel(tk.slider.right.frame, text="big tuning", fg="black", bg="white", font=visu.env$tk.font)
tkbind(tk.slider.big, "<ButtonRelease-1>", OnPlotSample) #Sample plotted only when mouse released
tkbind(tk.slider.big, "<ButtonRelease-2>", OnPlotSample) #Sample plotted only when mouse released
tkbind(tk.slider.tune, "<ButtonRelease-1>", OnPlotSample)
tkbind(tk.slider.tune, "<ButtonRelease-2>", OnPlotSample)
tk.mem.but <- tkbutton(tk.slider.left.frame, text="MR", command=OnMem, font=visu.env$tk.font)
tk.mem.hide.but <- tkbutton(tk.slider.left.frame, text="MC", command=OnMemHide, font=visu.env$tk.font)
tk.change.profile.mode <- tkbutton(tk.slider.left.frame, text="CPM", command=ChangeProfileMode, font=visu.env$tk.font)
tk.pairs.frame <- tkframe(tk.plot.frame, bg="white")
tk.pairs.valid.but <- tkbutton(tk.pairs.frame, text="Valid set of pairs", command=OnValidPairs, font=visu.env$tk.font)
tk.pairs.buts.frame <- tkframe(tk.pairs.frame, bg="white")
tk.pairs.label <- tklabel(tk.pairs.buts.frame, bg="white", fg="black", width=20, font=visu.env$tk.font)
tk.pairs.ML.but <- tkbutton(tk.pairs.buts.frame, text="ML Pair", command=OnML, font=visu.env$tk.font)
tk.pairs.CNL.but <- tkbutton(tk.pairs.buts.frame, text="CNL Pair", command=OnCNL, font=visu.env$tk.font)
tk.pairs.cancel.but <- tkbutton(tk.pairs.buts.frame, text="Cancel pair", command=OnCancelPair, font=visu.env$tk.font)
tk.protos.frame <- tkframe(tk.plot.frame, bg="white")
#tk.protos.valid.but <- tkbutton(tk.protos.frame, text="Valid set\nof protos", command=OnValidPairs)
tk.protos.buts.frame <- tkframe(tk.protos.frame, bg="white")
tk.protos.entry <- tkentry(tk.protos.frame, textvariable=visu.env$tcl.proto.label, width=50,
justify="left", fg="black", bg="white", font=visu.env$tk.font)
tk.cluster.rename.but <- tkbutton(tk.protos.buts.frame, text="Rename\ncluster", command=OnRenameCluster, font=visu.env$tk.font)
tk.protos.select.but <- tkbutton(tk.protos.buts.frame, text="Select\nproto", command=OnSelectProto, font=visu.env$tk.font)
tk.protos.cancel.but <- tkbutton(tk.protos.buts.frame, text="Cancel\nproto", command=OnCancelProto, font=visu.env$tk.font)
tkbind(tk.protos.entry, "<Leave>", OnLeaveProto)
#------------------
#positioning
#------------------
tkpack(tklabel(tk.plot.frame, text=visu.env$data.sample$name, fg="black",
bg="white", wraplength=600, font=visu.env$tk.font), fill="x")
tkpack(tk.plot.fig, fill="x")
tkpack(tk.plot.frame, side="left")
tkpack(tklabel(tk.plot.compare.frame, text=visu.env$data.sample$name, fg="black",
bg="white", wraplength=600, font=visu.env$tk.font), fill="x")
tkpack(tk.plot.compare.fig, fill="x")
if (visu.env$compare.mode!="off")
tkpack(tk.plot.compare.frame, side="left", anchor="n")
tkpack(tk.profile.fig, fill="x")
tkpack(tk.slider.big.label)
tkpack(tk.slider.big, fill="x")
tkpack(tk.slider.tune.label)
tkpack(tk.slider.tune, fill="x")
tkpack(tk.mem.but, fill="x")
tkpack(tk.mem.hide.but, fill="x")
tkpack(tk.change.profile.mode, fill="x")
tkpack(tk.slider.left.frame, side="left")
tkpack(tk.slider.center.frame, side="left")
tkpack(tk.slider.right.frame, side="left")
tkpack(tk.slider.frame, fill="x")
# tkpack(tk.profile.mem, sticky="n") #hidden
tkpack(tk.pairs.buts.frame, side="left")
tkpack(tk.pairs.valid.but, side="right")
tkpack(tk.pairs.label, side="left")
tkpack(tk.pairs.ML.but, side="left")
tkpack(tk.pairs.cancel.but, side="left")
tkpack(tk.pairs.CNL.but, side="left")
if (selection.mode=="pairs")
tkpack(tk.pairs.frame, fill="x")
tkpack(tk.protos.entry, side="left", padx=4)
tkpack(tk.protos.buts.frame, side="right")
#tkpack(tk.protos.valid.but, side="right")
tkpack(tk.cluster.rename.but, side="left")
tkpack(tk.protos.select.but, side="left")
tkpack(tk.protos.cancel.but, side="left")
if (selection.mode=="prototypes")
tkpack(tk.protos.frame, fill="x")
# tkpack(tk.profile.frame, side="right", padx=10, ipadx=10)
#initialisations
OnModifFeaturesMode()
OnModifPlotMode()
#horizontal axis - modification of feature
# ttt <- tkframe(tt)
# tkgrid(ttt, row=0, column=0, sticky="nw", padx=10)
# tkgrid(tklabel(ttt, text="Feature - First axis"), sticky="n")
# for (i in 1:length(feat)) {
# but <- tkradiobutton(ttt)
# tkconfigure(but, variable=featH.var, text=feat[i], value=feat[i], command=OnModif)
# tkgrid(but, sticky="w")
# }
# OnOK <- function(){
# tkdestroy(tt)
# }
# OK.but <- tkbutton(tt,text="End",command=OnOK)
# tkgrid(OK.but,row=14,column=1)
#default vizualisation
if ((selection.mode!="none")||wait.close)
tkwait.window(tt) ## A COMMENTER POUR LES TESTS
switch(selection.mode,
"prototypes"=list(prototypes=visu.env$prototypes,label=visu.env$data.sample$clustering),
"pairs"=list(ML=visu.env$pairs.values[visu.env$pairs.constraints==1],
CNL=visu.env$pairs.values[visu.env$pairs.constraints==-1]),
NULL
)
}
#' analyzePlot creates specific plot for data exploration/analysis.
#' @title Plot for data exploration/analysis
#' @description Create some specific plots for data exploration/analysis.
#' @param nb notebook in which the analyze plot will be added.
#' @param data.sample list containing features, profiles and clustering results.
#' @param selectedVar character vector containing the selected variables names to analyze.
#' @param type character vector specifying the analysis type. Must be 'boxplot', 'gapSE', 'histo', 'pcaCorr' or 'pcaVar'.
#' @param hscale numeric value corresponding to the horizontal scale of graphic.
#' @param K.max maximal number of clusters (K.Max=20 by default).
#' @param fontsize size of font (fontsize=11 by default).
#' @return None
#' @importFrom graphics barplot par layout boxplot title hist plot arrows text axis abline mtext box
#' @importFrom grDevices colorRampPalette
#' @importFrom corrplot corrplot
#' @importFrom stats cor
#' @import factoextra
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf <- tempfile()
#' write.table(dat, tf, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf)
#'
#' mainWindow <- tktoplevel()
#' tktitle(mainWindow) <- "Barplot clustering"
#' mainWindow$env$nb <- tk2notebook(mainWindow, tabs = c())
#' tkpack(mainWindow$env$nb, fill="both", expand= TRUE)
#'
#' analyzePlot(mainWindow$env$nb, x, selectedVar="x", type="boxplot")
#'
#'
#' @keywords internal
#'
analyzePlot <- function(nb, data.sample, selectedVar, type = "boxplot", hscale = 1.2, K.max=20, fontsize=11) {
datTemp <- data.sample$features[["preprocessed"]]$x[data.sample$id.clean,
which(colnames(data.sample$features[["preprocessed"]]$x) %in% selectedVar)]
# Check if all values are numeric
if (all(sapply(datTemp, is.numeric))) {
# Boxplot for selected parameter
if (type == "boxplot") {
tk2add.notetab(nb, " Statistics ", "Statistics")
tk2draw.notetab(nb, "Statistics", hscale = hscale,
function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg = "white", oma = c(0,2,2,0))
graphics::layout(matrix(c(1,2), 1, 2, byrow = TRUE), widths=c(1.5,2.5))
bp <- graphics::boxplot(data.sample$features[["preprocessed"]]$x[data.sample$id.clean,
which(colnames(data.sample$features[["preprocessed"]]$x) %in% selectedVar)],
main = NULL, ylab = "Values", outline = FALSE, col="black")
graphics::title(sub = paste("Max: ", toString(signif(bp$stats[5], digits = 5)),
"\n3rd quartile: ", toString(signif(bp$stats[4], digits = 5)),
"\nMedian: ", toString(signif(bp$stats[3], digits = 5)),
"\n1st quartile: ", toString(signif(bp$stats[2], digits = 5)),
"\nMin: ", toString(signif(bp$stats[1], digits = 5)), "\n", sep = ""),
adj = 1, font.sub = 1, cex.sub = 0.8)
graphics::hist(data.sample$features[["preprocessed"]]$x[data.sample$id.clean,
which(colnames(data.sample$features[["preprocessed"]]$x) %in% selectedVar)],
main = NULL, xlab = "Values", col="black")
graphics::title(selectedVar, outer=TRUE)
}
)
}
# Correlation circle from PCA for selected parameters
if (type == "pcaCorr") {
res.pca <- data.sample$features[[selectedVar]]$save
tk2add.notetab(nb, " PCA Correlation ", "pcaCorr")
tk2draw.notetab(nb, "pcaCorr", hscale = hscale,
function() {
p <- factoextra::fviz_pca_var(res.pca,
col.var = "contrib",
gradient.cols = c("#00AFBB", "#E7B800", "#FC4E07"),
repel = TRUE)
p <- p + ggplot2::theme(text = element_text(size = fontsize),
axis.title = element_text(size = fontsize),
axis.text = element_text(size = fontsize))
plot(p)
})
}
# Variances from PCA for selected parameters
if (type == "pcaVar") {
eig <- (data.sample$features[[selectedVar]]$sdev)^2
variance <- eig*100/sum(eig)
df=data.frame(Variance=variance ,CumVariance=cumsum(variance))
tk2add.notetab(nb, " PCA Variance ", "pcaVar")
tk2draw.notetab(nb, "pcaVar", hscale = hscale,
function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
xcoord <- seq(0.7, length(variance) * 1.2, by = 1.2)
graphics::par(bg = "white", mar = c(4,4,1,4)+.1)
bp <- graphics::barplot(variance, ylab = "Percentage of variance (%)",
xlim = c(0.2, xcoord[length(variance)]), col = "black")
graphics::axis(side = 1, at = bp, labels = paste("PC", 1:length(variance)))
graphics::par(new = TRUE)
graphics::plot(bp, cumsum(variance), xlim = c(0.2, xcoord[length(variance)]),
type = "o", col = "red", ylim = c(0, 100), lwd = 3, ann = FALSE, axes = FALSE)
graphics::axis(side = 4, col = "red", col.axis = "red")
graphics::mtext("Cumulative variance (%)", side = 4, line = 3, col = "red")
})
}
# Gap and K estimated from Spectral Embedding
if (type == "gapSE") {
length.eig <- length(data.sample$features[[selectedVar]]$eig)
eig <- data.sample$features[[selectedVar]]$eig[1:min(length.eig)]
gap <- data.sample$features[[selectedVar]]$gap
tk2add.notetab(nb, " Gap Spectral ", "gapSE")
tk2draw.notetab(nb, "gapSE", hscale = hscale,
function() {
opar <- graphics::par(no.readonly=TRUE)
on.exit(graphics::par(opar))
graphics::par(bg = "white")
graphics::plot(eig, type = "o", col = "blue", lwd = 3, ann = FALSE, axes = FALSE)
graphics::abline(v = which.max(gap), lwd = 2, lty = 2, col = "darkred")
graphics::abline(h = eig[which.max(gap)], lwd = 2, lty = 2, col = "darkred")
graphics::axis(side = 1, at = c(seq(0,K.max, by=5), which.max(gap)),
labels = c(seq(0,K.max, by=5), which.max(gap)), cex.axis = .7)
graphics::axis(side = 2, at = c(min(eig),max(eig)),
labels = c(signif(min(eig),2), max(eig)), las = 2, cex.axis = .7)
graphics::text(x = which.max(gap), y = max(eig)-0.01, "K", srt = 0, pos = 4, cex = .7, col = "darkred")
graphics::mtext("Index", side = 1, line = 3, col = "black")
graphics::mtext("Eigenvalue", side = 2, line = 3, col = "black")
graphics::box()
})
}
# Correlation circle
if (type == "Corr") {
data <- data.sample$features[["preprocessed"]]$x[data.sample$id.clean,selectedVar]
M <- stats::cor(data)
p.mat <- NULL
title.mat <- "Correlation matrix"
tryCatch(
expr = {
p.mat <- cor.mtest(M)
title.mat <- "Correlation matrix (p-value 5%)"
},
error = function(e){
if (grepl('not enough finite observations',as.character(e))==TRUE){
message("Not compatible with p-value test : not enough finite observations")
}
}
)
tk2add.notetab(nb, " Correlations ", "Corr")
tk2draw.notetab(nb, "Corr", hscale = hscale,
function() {
col <- grDevices::colorRampPalette(c("#BB4444", "#EE9988", "#FFFFFF", "#77AADD", "#4477AA"))
if (length(selectedVar) > 12){
corrplot::corrplot(M, type="upper", order="hclust", col=col(200),
p.mat = p.mat, sig.level = 0.05, insig = "blank", tl.col="black",
diag=FALSE,title= title.mat, mar=c(0,0,1,0), tl.cex= fontsize/11, cl.cex = fontsize/11, number.cex=fontsize/11)
} else {
corrplot::corrplot(M, method="color", col=col(200),
type="upper", order="hclust",
addCoef.col = "black",
tl.col="black", tl.srt=45,
p.mat = p.mat, sig.level = 0.05, insig = "blank",
diag=FALSE, title= title.mat, mar=c(0,0,1,0), tl.cex= fontsize/11, cl.cex = fontsize/11, number.cex=fontsize/11)
}
})
}
} else {
tkmessageBox(message = "Non numeric value(s) in the selected parameter(s)!", icon = "warning", type = "ok")
}
}
#' cor.mtest Correlation test on correlation matrix.
#' @title Correlation test.
#' @description Display the abundances barplot of a clustering.
#' @param mat correlation matrix
#' @return matrix with p-values.
#' @importFrom stats cor.test
#' @references \url{http://www.sthda.com/french/wiki/visualiser-une-matrice-de-correlation-par-un-correlogramme}
#' @keywords internal
cor.mtest <- function(mat) {
mat <- as.matrix(mat)
n <- ncol(mat)
p.mat<- matrix(NA, n, n)
diag(p.mat) <- 0
for (i in 1:(n - 1)) {
for (j in (i + 1):n) {
tmp <- stats::cor.test(mat[, i], mat[, j])
p.mat[i, j] <- p.mat[j, i] <- tmp$p.value
}
}
colnames(p.mat) <- rownames(p.mat) <- colnames(mat)
p.mat
}
#' abdPlotTabs displays the abundances barplot of a set of clusterings in Tk tabs of a notebook.
#' @title Abundances barplots inside Tk tabs.
#' @description Display the abundances barplot of a clustering.
#' @param clusterings clustering list.
#' @param nb a notebook.
#' @param RclusTool.env environment in which all global parameters, raw data and results are stored.
#' @param hscale numeric value corresponding to the horizontal scale of graphic.
#' @return None
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf <- tempfile()
#' write.table(dat, tf, sep=",", dec=".")
#'
#' mainWindow <- tktoplevel()
#' tktitle(mainWindow) <- "Barplot clustering"
#' mainWindow$env$nb <- tk2notebook(mainWindow, tabs = c())
#' tkpack(mainWindow$env$nb, fill="both", expand= TRUE)
#'
#' x <- importSample(file.features=tf)
#' method <- "K-means"
#'
#' x <- computeUnSupervised(x, K=3, method.name=method)
#'
#' abdPlotTabs(x$clustering, mainWindow$env$nb)
#'
#'
#' @keywords internal
#'
abdPlotTabs <- function(clusterings, nb, RclusTool.env=initParameters(), hscale=NULL)
{
if (is.null(hscale))
hscale <- 1.2
num.cluster <- 0
for (title in names(clusterings))
{
if (title == "no-clustering")
next
num.cluster <- num.cluster + 1
label <- clusterings[[title]]$label
text <- paste("", as.character(num.cluster),"")
tk2add.notetab(nb, text, as.character(num.cluster))
tk2draw.notetab(nb, as.character(num.cluster), hscale= hscale,
function() abdPlot(label, title, point.param=RclusTool.env$param$visu$palette.colors))
}
}
#' abdPlotTabsGUI calls abdPlotTabs to display the abundances barplot of the clusterings of the current RclusTool.env$data.sample, inside the GUI.
#' @title Abundances barplots inside Tk tabs.
#' @description Display the abundances barplot of a clustering.
#' @param RclusTool.env environment in which all global parameters, raw data and results are stored.
#' @return None
#'
#' @keywords internal
abdPlotTabsGUI <- function(RclusTool.env=initParameters())
{
clusterings <- RclusTool.env$data.sample$clustering
nb <- RclusTool.env$gui$win2$env$nb
hscale <- RclusTool.env$param$visu$hscale
if (!is.null(clusterings) && !is.null(nb))
abdPlotTabs(clusterings, nb, RclusTool.env, hscale=hscale)
}
#' abdPlot displays the abundances barplot of a clustering.
#' @title Abundances barplot
#' @description Display the abundances barplot of a clustering.
#' @param label factor describing the clustering.
#' @param title naming the graph.
#' @param charsize character size
#' @param point.param specifying the colors and the symbols to use for clusters display.
#' @return None
#' @importFrom grDevices colors
#' @importFrom graphics par barplot
#' @import ggplot2
#'
#' @examples
#' dat <- rbind(matrix(rnorm(100, mean = 2, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 4, sd = 0.3), ncol = 2),
#' matrix(rnorm(100, mean = 6, sd = 0.3), ncol = 2))
#' colnames(dat) <- c("x","y")
#' tf <- tempfile()
#' write.table(dat, tf, sep=",", dec=".")
#'
#' x <- importSample(file.features=tf)
#'
#' x <- computeUnSupervised(x, K=3, method.name='K-means')
#'
#' abdPlot(x[["clustering"]][["K-means_preprocessed"]][["label"]], 'K-means_preprocessed')
#'
#'
#' @keywords internal
#'
abdPlot <- function(label, title, charsize=11, point.param=c("grey","black","red","blue","green","cyan", "yellow","orange",
"rosybrown","palevioletred","darkblue","deeppink","blueviolet", 'darkgoldenrod1', 'chartreuse',
"darkorchid1", "deeppink", "coral", "darkolivegreen1","#66C2A5","#9DAE8C","#D49A73","#F08F6D",
"#C79693","#9E9DBA","#9F9BC9","#C193C6","#E28BC3","#D2A29F","#BABF77","#AAD852","#CBD844",
"#ECD836","#FAD53E","#F1CD64","#E7C689","#D7BF9C","#C5B9A7","#B3B3B3","#D53E4F","#E04F4A",
"#EB6046","#F47346","#F88B51","#FBA35C","#FDB869","#FDCA79","#FDDD88","#F6E68F","#EDEE93",
"#E2F398","#CDEA9D","#B7E2A1","#A0D8A4","#86CEA4","#6DC4A4","#58B2AB","#459DB4","#3288BD")){
l=levels(label)
id=names(label)
values=unname(label)
df<-data.frame(id=id,label=values)
p <- ggplot2::ggplot(df, aes(factor(label),fill=label)) + ggplot2::geom_bar() + ggplot2::scale_x_discrete(drop=FALSE)
p <- p + ggplot2::xlab("") + ggplot2::ylab("Abundances")
p <- p + ggplot2::ggtitle(title)
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::theme(axis.text.x = element_text(angle = 90, size=11))
p <- p + ggplot2::scale_fill_manual(values=point.param[1:length(l)], drop=FALSE)
p <- p + ggplot2::theme(legend.position='none')
p <- p + ggplot2::theme(axis.text.x = element_text(size = charsize))
p <- p + ggplot2::theme(axis.text.y = element_text(size = charsize))
p <- p + ggplot2::theme(plot.title = element_text(size = charsize))
print(p)
}
#' ElbowPlot displays the Elbow plot after a clustering step.
#' @title Elbow Plot.
#' @description Display the Elbow Plot after a clustering step.
#' @param nb tk-notebook in which the Elbow plot will be made.
#' @param method.space.name complete name of space.
#' @param RclusTool.env : environment in which data and intermediate results are stored.
#' @param hscale numeric value corresponding to the horizontal scale of graphic
#' @param charsize character size
#' @return None
#' @import ggplot2
#' @keywords internal
ElbowPlot <- function(nb, method.space.name, RclusTool.env, hscale= 1.2, charsize=11) {
Within=RclusTool.env$data.sample$clustering[[method.space.name]]$Within
K=ElbowFinder(1:length(Within),Within)
df=data.frame(K= 1:length(Within) , Within=Within)
tk2add.notetab(nb, " Elbow ", "Elbow")
tk2draw.notetab(nb, "Elbow", hscale= hscale,
function() {
tryCatch(
expr = {
p <- ggplot2::ggplot(data=df, ggplot2::aes(x=K, y=Within))
p <- p + ggplot2::geom_line(size=1) + geom_point()
p <- p + ggplot2::scale_color_manual(values=(col))
p <- p + ggplot2::xlab("K") + ggplot2::ylab("Withins tot")
p <- p + ggplot2::theme(plot.title = ggplot2::element_text(hjust = 0.5))
p <- p + ggplot2::ggtitle(paste('Elbow', method.space.name, sep=" "))
p <- p + ggplot2::geom_vline(xintercept = K, linetype="dashed", color = "red", size=1.5)
p <- p + ggplot2::scale_x_continuous(breaks=1:length(Within))
p <- p + ggplot2::theme(axis.text.x = element_text(size = charsize))
p <- p + ggplot2::theme(axis.text.y = element_text(size = charsize))
p <- p + ggplot2::theme(plot.title = element_text(size = charsize))
print(p)
},
error = function(e){
if (grepl('-monotype-arial',as.character(e))==TRUE){
message("Error :Please, Try to install gsfonts-x11")
}
}
)
}
)
}
#' tk2delete.notetab delete a notetab
#' @title Delete notetab inside a tk-notebook
#' @description Delete notetab inside a tk-notebook.
#' @param nb : a notebook.
#' @param tab.names : either NULL to delete all the notetabs, or a vector of notetab names.
#' @return None
#' @keywords internal
tk2delete.notetab <- function(nb, tab.names=NULL)
{
ids <- names(nb$env) # noms des objets
nt.ok <- sapply(ids, function(x) inherits(nb$env[[x]],"ttk2notetab"))
ids <- ids[nt.ok] #noms des onglets de classe tk2notetab
if (is.null(tab.names))
tab.names <- ids
for (id in tab.names)
{
tkdestroy(nb$env[[id]])
rm(list=id, envir=nb$env)
}
}
#' tk2add.notetab add a notetab.
#' @title Add notetab.
#' @description Add a notetab.
#' @param nb a notebook.
#' @param tab.label string the label of a tab on the interface.
#' @param tab.name string the name of the tab in a notebook.
#' @return None
#' @keywords internal
tk2add.notetab <- function(nb, tab.label, tab.name=NULL)
{
if (is.null(tab.name))
tab.name <- tab.label
tframe <- tk2frame(nb)
tkadd(nb, tframe, text=tab.label, sticky="nsew")
tk2notetab.RclusTool(nb, tab.label, tab.name)
}
#' tk2draw.notetab draw in a notetab.
#' @title Draw in a Notetab.
#' @description Draw in a Notetab with a function.
#' @param nb a notebook.
#' @param tab.name string : name of the tk2notetab variable.
#' @param hscale numeric value corresponding to the horizontal scale of graphic
#' @param fun : a function.
#' @return None
#' @keywords internal
tk2draw.notetab <- function(nb, tab.name, fun, hscale= 1.2){
Plot <- tkrplot.RclusTool(nb$env[[tab.name]], hscale = hscale, fun=fun)
tkgrid(Plot, row = 0, column = 1, sticky = "w")
}
#' tk2notetab.RclusTool RclusTool adaptation of tk2notetab.
#' @title RclusTool tk2notetab.
#' @description RclusTool adaptation of tk2notetab; builds and returns a R tk2notetab matching a notetab already declared in tk notebook.
#' @param nb a tk2notebook or ttk2notebook widget.
#' @param tab.label string the label of a tab on the interface.
#' @param tab.name string the name of the tab in a notebook.
#' @return None
#' @keywords internal
tk2notetab.RclusTool <- function (nb, tab.label, tab.name=NULL)
{
if (inherits(nb, "tk2notebook")) {
if (is.null(tab.name))
tab.name <- tab.label
ntab <- as.numeric(tcl(nb, "index", "end"))
if (ntab < 1)
return(NULL)
tabid <- ""
for (i in 0:(ntab - 1)) if (tclvalue(tcl(nb, "tab", i,
"-text")) == tab.label) {
tabid <- as.character(tcl(nb,"tabs"))[i+1]
break
}
if (tabid !="") {
w <- list()
w$ID <- tabid
w$env <- new.env()
w$env$num.subwin <- 0
w$env$parent <- nb
class(w) <- c("ttk2notetab", "tk2container", "tkwin")
nb$env[[tab.name]] <- w #sauvegarde dans l'environnement du notebook
return(w)
}
else return(NULL)
}
else stop("'nb' must be a 'tk2notebook' object")
}
#' tkrplot.RclusTool RclusTool adaptation of tkrplot.
#' @title RclusTool tkrplot.
#' @description RclusTool adaptation of tkrplot.
#' @param graphicFrame : frame of the RclusTool interface in which graphics should be displayed.
#' @param fun : a function
#' @param hscale numeric value corresponding to the horizontal scale of graphic
#' @param vscale : vertical scale
#' @return None
#' @importFrom grDevices png
#' @keywords internal
tkrplot.RclusTool <- function(graphicFrame, fun, hscale=1.0, vscale=1.0)
{
file <- tempfile()
grDevices::png(file, width=hscale*480, height=vscale*480)
try(fun())
dev.off()
image <- tclVar()
tkimage.create("photo", image, file = file)
lab <- tklabel(graphicFrame, image=image)
tkbind(lab, "<Destroy>", function() .Tcl(paste("image delete", image)))
lab$file <- file
lab$image <- image
lab$fun <- fun
lab$graphicFrame <- graphicFrame
lab$hscale <- hscale
lab$vscale <- vscale
lab
}
#' tkrreplot.RclusTool RclusTool adaptation of tkrreplot.
#' @title RclusTool tkrreplot.
#' @description RclusTool adaptation of tkrreplot.
#' @param env.graphic : graphic environment generated by tkrplot.RclusTool
#' @seealso \code{\link{tkrreplot.RclusTool}}
#' @return None
#' @importFrom grDevices png
#' @keywords internal
tkrreplot.RclusTool <- function(env.graphic)
{
grDevices::png(env.graphic$file, width=env.graphic$hscale*480, height=env.graphic$vscale*480)
try(env.graphic$fun())
dev.off()
tkimage.create("photo", env.graphic$image, file=env.graphic$file)
}
#' makeTitle Makes a title from a string.
#' @title RclusTool makeTitle.
#' @description Makes a character title from string by completion with a specified character.
#' @param string: string to be completed
#' @param length: final title length in characters
#' @param prefix.length: space length in front of the title
#' @param char: character used to complete the title
#' @return title
#' @keywords internal
makeTitle <- function(string, length=120, prefix.length=5, char='_'){
n.reps <- length - nchar(string) - prefix.length
if (n.reps<1)
return(string)
string_return <- paste(strrep(char, 5), string, strrep(char, n.reps), sep='')
return(string_return)
}
#' tkEmptyLine Inserts an empty line in a graphical tk objects dealt with grid.
#' @title RclusTool tkEmptyLine.
#' @description Makes a character title from string by completion with a specified character.
#' @param tk.object: tk object in which to insert the new line
#' @param row: row number of the insertion
#' @return None
#' @keywords internal
tkEmptyLine <- function(tk.object, row=NULL)
{
label <- tklabel(tk.object, text=" ")
if (!is.null(row)) {
tkgrid(label, row = row)
} else {
tkgrid(label)
}
}
#' consoleMessage Adds a message in the RclusTool GUI.
#' @title RclusTool consoleMessage.
#' @description Adds a message in the RclusTool GUI.
#' @param message: string to print in the console.
#' @param RclusTool.env environment in which all global parameters, raw data and results are stored.
#' @return None
#' @keywords internal
messageConsole <- function(message, RclusTool.env=initParameters())
{
console <- RclusTool.env$gui$console
if (!is.null(console))
{
tkinsert(console, "0.0", message)
}
}
Try the RclusTool 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.