Nothing
#' @title An interactive scatterplot matrix
#'
#' @description Function creates a scatterplot matrix using loon's scatterplot
#' widgets
#'
#' @param data a data.frame with numerical data to create the scatterplot matrix
#' @param connectedScales Determines how the scales of the panels are to be connected.
#' \itemize{
#' \item{\code{"cross"}: only the scales in the same row and the same column are connected;}
#' \item{\code{"none"}: neither "x" nor "y" scales are connected in any panels.}
#' }
#' @param linkingGroup string giving the linkingGroup for all plots. If missing,
#' a default \code{linkingGroup} will be determined from deparsing the \code{data}.
#' @param linkingKey a vector of strings to provide a linking identity for each row of the
#' \code{data} data.frame. If missing, a default \code{linkingKey} will be \code{0:(nrows(data)-1)}.
#' @param showItemLabels TRUE, logical indicating whether its itemLabel pops up over a point when
#' the mouse hovers over it.
#' @param itemLabel a vector of strings to be used as pop up information when the mouse hovers
#' over a point. If missing, the default \code{itemLabel} will be the \code{row.names(data)}.
#' @param showHistograms logical (default FALSE) to show histograms of each variable
#' or not
#' @param histLocation one "edge" or "diag", when showHistograms = TRUE
#' @param histHeightProp a positive number giving the height of the histograms as a
#' proportion of the height of the scatterplots
#' @param histArgs additional arguments to modify the `l_hist` states
#' @param showSerialAxes logical (default FALSE) indication of whether to show a serial axes plot
#' in the bottom left of the pairs plot (or not)
#' @param serialAxesArgs additional arguments to modify the `l_serialaxes` states
#' @template param_parent
#' @param plotWidth default plot width (in pixel)
#' @param plotHeight default plot height (in pixel)
#' @param span How many column/row occupies for each widget
#' @param showProgressBar Logical; show progress bar or not
#' @param ... named arguments to modify the `l_plot` states of the scatterplots
#'
#' @return an `l_pairs` object (an `l_compound` object), being a list with named elements,
#' each representing a separate interactive plot.
#' The names of the plots should be self explanatory and a list
#' of all plots can be accessed from the `l_pairs` object via `l_getPlots()`.
#' All plots are linked by default (name taken from data set if not provided).
#' Panning and zooming are constrained to work together within the scatterplot
#' matrix (and histograms).
#'
#' @seealso \code{\link{l_plot}} and \code{\link{l_getPlots}}
#'
#' @export
#'
#' @importFrom utils setTxtProgressBar txtProgressBar
#'
#' @examples
#' if(interactive()){
#'
#' p <- l_pairs(iris[,-5], color=iris$Species, linkingGroup = "iris")
#'
#' p <- l_pairs(iris[,-5], color=iris$Species, linkingGroup = "iris",
#' showHistograms = TRUE, showSerialAxes = TRUE)
#' # plot names
#' names(p)
#'
#' # Each plot must be accessed to make changes not managed through
#' # linking.
#' # E.g. to change the glyph on all scatterplots to open circles
#' for (plot in l_getPlots(p)) {
#' if (is(plot, "l_plot")) {
#' plot["glyph"] <- "ocircle"}
#' }
#'
#' }
l_pairs <- function(data,
connectedScales = c("cross", "none"),
linkingGroup, linkingKey, showItemLabels = TRUE, itemLabel,
showHistograms = FALSE, histLocation = c("edge", "diag"),
histHeightProp = 1, histArgs = list(),
showSerialAxes = FALSE, serialAxesArgs = list(), parent=NULL,
plotWidth = 100, plotHeight = 100, span = 10L, showProgressBar = TRUE, ...) {
### as the number of plots rises, the running time increases dramatically
### so we provide a progress bar to give the progress information
# the minimum length of plots to give the progress bar
minLenToGivePb <- 10L
substitueData <- deparse(substitute(data))
# matrix input
data <- as.data.frame(data)
dotArgs <- list(...)
new.linkingGroup <- FALSE
if (missing(linkingGroup)) {
new.linkingGroup <- TRUE
linkingGroup <- paste0("l_pairs_", substitueData)
}
call <- match.call()
# Use default as in tcl/tk
if (missing(linkingKey)) {
linkingKey <- NULL
}
if (missing(itemLabel)) {
itemLabel <- row.names(data)
}
if (length(itemLabel) != nrow(data)) {
warning("itemLabel length not equal to number of observations, using row.names(data) instead")
itemLabel <- row.names(data)
}
connectedScales <- match.arg(connectedScales)
sync <- dotArgs[['sync']]
# if null, it is always **pull**
if(is.null(sync)) sync <- "pull"
dotArgs[['sync']] <- NULL
dotArgs[['x']] <- NULL
dotArgs[['y']] <- NULL
dotArgs[['linkingKey']] <- linkingKey
dotArgs[['itemLabel']] <- itemLabel
dotArgs[['showItemLabels']] <- showItemLabels
if(!is.null(dotArgs[['by']])) {
warning("'l_pairs' does not support facetting layouts")
dotArgs[['by']] <- NULL
}
if (dim(data)[2] < 2) {
dotArgs[['x']] <- data
dotArgs[['parent']] <- parent
return(do.call(l_plot, dotArgs))
}
# if (dim(data)[2] == 2) {
# dotArgs[['x']] <- data
# dotArgs[['parent']] <- parent
# return(do.call(l_plot, dotArgs))
# }
dotArgs[['showLabels']] <- FALSE
dotArgs[['showScales']] <- FALSE
dotArgs[['swapAxes']] <- FALSE
new.toplevel <- FALSE
if(is.null(parent)) {
new.toplevel <- TRUE
parent <- l_toplevel()
}
subwin <- l_subwin(parent, 'pairs')
child <- as.character(tcl('frame', subwin))
title <- paste("loon scatterplot matrix for",
substitueData, "data", "--path:", subwin)
tktitle(parent) <- title
## parent for individual scatterplots
dotArgs[['parent']] <- child
nvar <- dim(data)[2]
pair <- utils::combn(nvar, 2)
varnames <- names(data)
## combn returns the variable combinations for the scatterplot
## matrix. The scatterplot arrangements is as follows
##
## 1 2 3 4
## 1 [1] (2,1) (3,1) (4,1)
## 2 [2] (3,2) (4,2)
## 3 [3] (4,3)
## 4 [4]
##
##
## pair is
## 1 1 1 2 2 3
## 2 3 4 3 4 4
scatter_adjustValue <- 0
histLocation <- match.arg(histLocation)
histspan <- 0L
totalNumPlots <- 0L
numScatterPlots <- dim(pair)[2]
numHistPlots <- 0L
numSerialaxesPlot <- 0L
totalNumPlots <- totalNumPlots + numScatterPlots
if(showHistograms) {
numHistPlots <- if(histLocation == "edge") {
2*nvar - 2
} else {
# diag
nvar
}
totalNumPlots <- totalNumPlots + numHistPlots
}
if(showSerialAxes) {
numSerialaxesPlot <- 1
totalNumPlots <- totalNumPlots + numSerialaxesPlot
}
if(showProgressBar)
pbPlots <- l_txtProgressBar(min = 0, max = totalNumPlots,
minLenToGivePb = minLenToGivePb,
message = "Prepare Plots:")
histograms <- list()
if (showHistograms) {
if(is.null(histArgs[['showStackedColors']])) histArgs[['showStackedColors']] <- TRUE
if(is.null(histArgs[['showOutlines']])) histArgs[['showOutlines']] <- FALSE
if(is.null(histArgs[['yshows']])) histArgs[['yshows']] <- "density"
if(is.null(histArgs[['showBinHandle']])) histArgs[['showBinHandle']] <- FALSE
if(!is.null(histArgs[['by']])) {
warning("'l_pairs' does not support facetting layouts", call. = FALSE)
histArgs[['by']] <- NULL
}
# histArgs is consistent with dotArgs
histArgs[['showLabels']] <- dotArgs[['showLabels']]
histArgs[['showScales']] <- dotArgs[['showScales']]
histArgs[['parent']] <- dotArgs[['parent']]
histArgs[['linkingGroup']] <- NULL
histArgs[['linkingKey']] <- dotArgs[['linkingKey']]
switch(histLocation,
"edge" = {
histspan <- round(histHeightProp * span)
# The first half are top hists, the second half are right hists
index <- seq(numHistPlots) + 1
for(i in index) {
if (i <= nvar) {
histArgs[['x']] <- data[[varnames[i]]] # as.numeric(data[[varnames[i]]])
histArgs[['xlabel']] <- varnames[i]
# top level histograms
histArgs[['swapAxes']] <- FALSE
ix <- i
iy <- 1
} else {
histArgs[['x']] <- data[[varnames[i - nvar]]] # as.numeric(data[[varnames[i - nvar]]])
histArgs[['xlabel']] <- varnames[i - nvar]
# right level histograms
histArgs[['swapAxes']] <- TRUE
ix <- nvar + 1
iy <- i - nvar + 1
}
histograms[[i]] <- do.call(l_hist, histArgs)
names(histograms)[i] <- paste('x',ix,'y',iy, sep="")
if(showProgressBar)
l_setTxtProgressBar(pbPlots, i - 1)
}
# throw errors
if (any(sapply(histograms, function(p) {is(p, 'try-error')}))) {
if(new.toplevel) tkdestroy(parent)
stop("histogram could not be created.")
}
sapply(index,
function(i) {
h <- histograms[[i]]
if(i <= nvar){
tkconfigure(paste(h,'.canvas',sep=''),
width=plotWidth,
height=plotHeight * histHeightProp)
} else {
tkconfigure(paste(h,'.canvas',sep=''),
width=plotWidth * histHeightProp,
height=plotHeight)
}
}
)
# grid layout
lapply(index,
function(i){
if(i <= nvar) {
tkgrid(histograms[[i]], row = 0,
column = (i-1) * span,
rowspan = histspan, columnspan = span,
sticky="nesw")
} else {
tkgrid(histograms[[i]], row = histspan + (i - nvar - 1)* span,
column = nvar * span,
rowspan = span, columnspan = histspan,
sticky="nesw")
}
}
)
scatter_adjustValue <- 1
},
"diag" = {
if(histHeightProp != 1) {
warning("histHeightProp must be 1 when histograms are placed on diagonal")
histHeightProp <- 1
}
for(i in seq(numHistPlots)) {
histArgs[['x']] <- data[[varnames[i]]] # as.numeric(data[[varnames[i]]])
histArgs[['xlabel']] <- varnames[i]
histArgs[['swapAxes']] <- FALSE
histograms[[i]] <- do.call(l_hist, histArgs)
xText <- histograms[[i]]['panX'] + histograms[[i]]['deltaX']/(2*histograms[[i]]['zoomX'])
yText <- histograms[[i]]['panY'] + histograms[[i]]['deltaY']/(2*histograms[[i]]['zoomY'])
layerText <- l_layer_text(histograms[[i]], xText, yText, text = names(data)[i],
color = "black", size = 8)
names(histograms)[i] <- paste('x',i,'y',i, sep="")
if(showProgressBar)
l_setTxtProgressBar(pbPlots, i)
}
# throw errors
if (any(sapply(histograms, function(p) {is(p, 'try-error')}))) {
if(new.toplevel) tkdestroy(parent)
stop("histogram could not be created.")
}
sapply(seq_len(numHistPlots),
function(i) {
h <- histograms[[i]]
tkconfigure(paste(h,'.canvas',sep=''), width=plotWidth, height=plotHeight)
}
)
# grid layout
lapply(seq_len(numHistPlots),
function(i){
tkgrid(histograms[[i]], row = (i-1) * span, column = (i-1) * span,
rowspan = span, columnspan = span,
sticky="nesw")
}
)
})
histograms <- Filter(Negate(is.null), histograms)
namesHist <- names(histograms)
histLayout <- xy_layout(namesHist)
histX <- histLayout$x
histY <- histLayout$y
}
if (showSerialAxes) {
serialAxesArgs[['data']] <- data
serialAxesArgs[['showScales']] <- NULL
serialAxesArgs[['swapAxes']] <- NULL
serialAxesArgs[['axesLayout']] <- "parallel"
serialAxesArgs[['showLabels']] <- dotArgs[['showLabels']]
serialAxesArgs[['parent']] <- dotArgs[['parent']]
serialAxesArgs[['linkingGroup']] <- NULL
serialAxesArgs[['linkingKey']] <- dotArgs[['linkingKey']]
serialAxesArgs[['itemLabel']] <- dotArgs[['itemLabel']]
serialAxesArgs[['showItemLabels']] <- dotArgs[['showItemLabels']]
if(!is.null(serialAxesArgs[['by']])) {
warning("'l_pairs' does not support facetting layouts")
serialAxesArgs[['by']] <- NULL
}
serialAxesSpan <- floor(nvar/2)
serialAxes <- do.call(l_serialaxes, serialAxesArgs)
if(showProgressBar)
# give progress bar
l_setTxtProgressBar(pbPlots, numHistPlots + 1)
tkconfigure(paste(serialAxes,'.canvas',sep=''),
width= serialAxesSpan * plotWidth,
height = serialAxesSpan * plotHeight)
tkgrid(serialAxes,
row = (nvar - serialAxesSpan) * span + histspan, column = 0,
rowspan = serialAxesSpan * span, columnspan = serialAxesSpan * span,
sticky="nesw")
}
scatterplots <- vector(mode="list", dim(pair)[2])
## create first plot
for (i in 1:dim(pair)[2]) {
ix <- pair[2,i]
iy <- pair[1,i]
dotArgs[['xlabel']] <- varnames[ix]
dotArgs[['ylabel']] <- varnames[iy]
dotArgs[['x']] <- data[[varnames[ix]]]
dotArgs[['y']] <- data[[varnames[iy]]]
scatterplots[[i]] <- do.call(l_plot, dotArgs)
if(showProgressBar)
# give progress bar
l_setTxtProgressBar(pbPlots, i + numHistPlots + numSerialaxesPlot)
# reset names (if showHistograms)
if (showHistograms & histLocation == "edge") {
names(scatterplots)[i] <- paste('x',ix,'y',iy + 1, sep="")
} else {
names(scatterplots)[i] <- paste('x',ix,'y',iy, sep="")
}
}
if(showProgressBar)
# close the pb
l_close(pbPlots)
namesScatter <- names(scatterplots)
scatterLayout <- xy_layout(namesScatter)
scatterX <- scatterLayout$x
scatterY <- scatterLayout$y
if (any(sapply(scatterplots, function(p) {is(p, 'try-error')}))) {
if(new.toplevel) tkdestroy(parent)
stop("scatterplot matrix could not be created.")
}
## resize the min canvas size
sapply(scatterplots,
function(p) {
tkconfigure(paste(p,'.canvas',sep=''),
width=plotWidth,
height=plotHeight)
}
)
## grid layout
apply(rbind(unlist(scatterplots), pair - 1), 2,
function(obj) {
tkgrid(obj[1],
row= as.numeric(obj[2]) * span + scatter_adjustValue * histspan,
column = as.numeric(obj[3]) * span,
rowspan = span,
columnspan = span,
sticky="nesw")
}
)
## Column and Row weight such that the cells expand
for (i in seq(0, nvar * span + histspan - 1)) {
tkgrid.columnconfigure(child, i, weight = 1)
tkgrid.rowconfigure(child, i, weight = 1)
}
## Add Variable Label
if (!showHistograms | all(c(showHistograms, histLocation == "edge"))){
maxchar <- max(sapply(names(data), nchar))
strf <- paste("%-", maxchar,'s', sep='')
for (i in 1:nvar) {
lab <- as.character(tcl('label',
as.character(l_subwin(child,'label')),
text= sprintf(strf, names(data)[i])))
tkgrid(lab,
row = (i - 1) * span + histspan,
column = (i - 1) * span,
rowspan = span,
columnspan = span)
}
}
if(new.toplevel) {
tkpack(child, fill="both", expand=TRUE)
}
if(showProgressBar)
pbScales <- l_txtProgressBar(min = 0, max = numScatterPlots,
minLenToGivePb = minLenToGivePb,
message = "Bind Scales:")
plotsHash <- list()
for (i in seq(numScatterPlots)) {
ix <- pair[2,i]
iy <- pair[1,i]
tmpX <- which(pair[2,] == ix)
shareX <- tmpX[tmpX != i]
tmpY <- which(pair[1,] == iy)
shareY <- tmpY[tmpY != i]
plotsHash[[paste0("scatter_y_", scatterplots[i])]] <- scatterplots[shareY]
if(showHistograms) {
histShareX <- which(histX %in% scatterX[i])
histShareY <- which(histY %in% scatterY[i])
plotsHash[[paste0("scatter_x_", scatterplots[i])]] <- c(scatterplots[shareX], histograms[histShareX])
plotsHash[[paste0("swap_hist_", scatterplots[i])]] <- histograms[histShareY]
if(histLocation == "diag") {
plotsHash[[paste0("hist_sync_y", scatterplots[i])]] <- c(scatterplots[scatterY %in% histShareX])
plotsHash[[paste0("hist_sync_x", scatterplots[i])]] <- c(scatterplots[scatterX %in% histShareY])
}
} else {
plotsHash[[paste("scatter_x_",
scatterplots[i],
sep="")]] <- scatterplots[shareX]
}
if(showProgressBar)
l_setTxtProgressBar(pbScales, i)
}
if(showProgressBar)
l_close(pbScales)
## Make bindings for scatter synchronizing zoom and pan
busy <- FALSE
synchronizeScatterBindings <- function(W) {
#print(paste(W, ', busy', busy))
if (!busy) {
busy <<- TRUE
class(W) <- "loon"
zoomX <- W['zoomX']; zoomY <- W['zoomY']
panX <- W['panX']; panY <- W['panY']
deltaX <- W['deltaX']; deltaY <- W['deltaY']
lapply(plotsHash[[paste0("scatter_x_",W)]], function(p) {
if(is.null(p)) return(NULL)
l_configure(p, zoomX=zoomX, panX=panX, deltaX=deltaX)
})
lapply(plotsHash[[paste0("scatter_y_",W)]], function(p) {
if(is.null(p)) return(NULL)
l_configure(p, zoomY=zoomY, panY=panY, deltaY=deltaY)
})
if (showHistograms) {
lapply(plotsHash[[paste0("swap_hist_",W)]], function(p) {
if(is.null(p)) return(NULL)
l_configure(p, zoomX=zoomY, panX=panY, deltaX=deltaY)
})
if(histLocation == "diag") {
lapply(plotsHash[[paste0("hist_sync_x",W)]],
function(p) {
if(is.null(p)) return(NULL)
l_configure(p, zoomX=zoomY, panX=panY, deltaX=deltaY)
})
lapply(plotsHash[[paste0("hist_sync_y",W)]],
function(p) {
if(is.null(p)) return(NULL)
l_configure(p, zoomY=zoomX, panY=panX, deltaY=deltaX)
})
}
}
busy <<- FALSE
tcl('update', 'idletasks')
##assign("busy", FALSE, envir=parent.env(environment()))
}
}
lapply(scatterplots,
function(p) {
if(connectedScales == "cross") {
tcl(p, 'systembind', 'state', 'add',
c('zoomX', 'panX', 'zoomY', 'panY', 'deltaX', 'deltaY'),
synchronizeScatterBindings)
}
tcl(p, 'systembind', 'state', 'add',
c('showLabels', 'showScales', 'swapAxes'),
undoScatterStateChanges)
}
)
plots <- scatterplots
if (showHistograms) {
# synchronize hist bindings
histsHash <- list()
setHistScalesStartTime <- Sys.time()
if(histLocation == "edge") {
for(i in seq(numHistPlots)) {
if(i <= (nvar - 1)) {
shareX <- which(scatterX %in% histX[i])
histsHash[[paste0("hist_x_", histograms[i])]] <- c(scatterplots[shareX])
} else {
shareY <- which(scatterY %in% histY[i])
histsHash[[paste0("hist_y_", histograms[i])]] <- c(scatterplots[shareY])
}
}
} else {
for(i in seq(numHistPlots)) {
shareX <- which(scatterX %in% histX[i])
shareY <- which(scatterY %in% histY[i])
if(length(shareX) > 0) {
histsHash[[paste0("hist_x_", histograms[i])]] <- c(scatterplots[shareX])
}
if(length(shareY) > 0) {
histsHash[[paste0("hist_y_", histograms[i])]] <- c(scatterplots[shareY])
}
}
}
synchronizeHistBindings <- function(W) {
#print(paste(W, ', busy', busy))
if (!busy) {
busy <<- TRUE
class(W) <- "loon"
zoomX <- W['zoomX']; zoomY <- W['zoomY']
panX <- W['panX']; panY <- W['panY']
deltaX <- W['deltaX']; deltaY <- W['deltaY']
lapply(histsHash[[paste("hist_x_",W,sep="")]], function(h) {
if(is.null(h)) return(NULL)
l_configure(h, zoomX=zoomX, panX=panX, deltaX=deltaX)
})
lapply(histsHash[[paste("hist_y_",W,sep="")]], function(h) {
if(is.null(h)) return(NULL)
l_configure(h, zoomY=zoomX, panY=panX, deltaY=deltaX)
})
busy <<- FALSE
tcl('update', 'idletasks')
##assign("busy", FALSE, envir=parent.env(environment()))
}
}
# forbidden
lapply(histograms,
function(h) {
if(is.null(h)) return(NULL)
if(connectedScales == "cross") {
tcl(h, 'systembind', 'state', 'add',
c('zoomX', 'panX', 'zoomY', 'panY', 'deltaX', 'deltaY'),
synchronizeHistBindings)
}
tcl(h, 'systembind', 'state', 'add',
c('showLabels', 'showScales'),
undoHistStateChanges)
})
plots<- c(plots, histograms)
callbackFunctions$state[[paste(child,"synchronizeHist", sep="_")]] <- synchronizeHistBindings
callbackFunctions$state[[paste(child,"undoHistStateChanges", sep="_")]] <- undoHistStateChanges
}
if(showSerialAxes) {
plots <- c(plots, list(serialAxes = serialAxes))
}
if(showProgressBar)
# configure sync
pbLinking <- l_txtProgressBar(min = 0, max = totalNumPlots,
minLenToGivePb = minLenToGivePb,
message = "Configure plot linking:")
lapply(seq(totalNumPlots),
function(i) {
plot <- plots[[i]]
type <- class(plot)[1L]
modifiedLinkedStates <- l_modifiedLinkedStates(type, names(call))
if(!new.linkingGroup) {
syncTemp <- ifelse(length(modifiedLinkedStates) == 0, sync, "pull")
# give message once
if(i == 1L && syncTemp == "push") {
message("The modification of linked states is not detected",
" so that the default settings will be pushed to all plots")
}
l_configure(plot,
linkingGroup = linkingGroup,
sync = syncTemp)
if(sync == "push" && length(modifiedLinkedStates) > 0) {
do.call(l_configure,
c(
list(
target = plot,
linkingGroup = linkingGroup,
sync = sync
),
dotArgs[modifiedLinkedStates]
)
)
} else {
if(i == 1L) {
l_linkingWarning(plot, sync, args = dotArgs,
modifiedLinkedStates = modifiedLinkedStates)
}
}
} else {
l_configure(plot,
linkingGroup = linkingGroup,
sync = sync)
}
if(showProgressBar)
l_setTxtProgressBar(pbLinking, i)
})
if(showProgressBar)
l_close(pbLinking)
## beware undoScatterStateChanges and synchronizeScatterBindings from garbage collector
callbackFunctions$state[[paste(child,"synchronizeScatter", sep="_")]] <- synchronizeScatterBindings
callbackFunctions$state[[paste(child,"undoScatterStateChanges", sep="_")]] <- undoScatterStateChanges
structure(
plots,
class = c("l_pairs", "l_compound", "loon")
)
}
## forbidden states
undoScatterStateChanges <- function(W) {
warning("showLabels, showScales, and swapAxes can not be changed for scatterplot matrix.")
l_configure(W, showLabels = FALSE, showScales = FALSE, swapAxes = FALSE)
}
undoHistStateChanges <- function(W) {
warning("showLabels, showScales can not be changed for scatterplot matrix.")
l_configure(W, showLabels = FALSE, showScales = FALSE)
}
# names must follow the pattern xayb, (a,b) is the coords of the corresponding layout
xy_layout <- function(names){
namesSplit <- strsplit(names, split = "")
lay_out <- as.data.frame(
t(
sapply(namesSplit,
function(char){
xpos <- which(char %in% "x" == TRUE)
ypos <- which(char %in% "y" == TRUE)
len_char <- length(char)
c(as.numeric(paste0(char[(xpos + 1) : (ypos - 1)], collapse = "")),
as.numeric(paste0(char[(ypos + 1) : (len_char)], collapse = "")))
}
)
)
)
colnames(lay_out) <- c("x", "y")
lay_out
}
#' @rdname l_getPlots
#'
#' @export
l_getPlots.l_pairs <- function(target){
# throw errors if elements of compound are a not loon widget
lapply(target,
function(tar){l_throwErrorIfNotLoonWidget(tar) }
)
target
}
#' @rdname l_getLocations
#'
#' @export
l_getLocations.l_pairs <- function(target) {
nPlots <- length(target)
nScatterplots <- nHistograms <- nSerialAxes <- 0
scatterplots <- histograms <- serialAxes <- list()
plotNames <- names(target)
for(i in 1:nPlots) {
if(inherits(target[[i]], "l_plot")) {
nScatterplots <- nScatterplots + 1
scatterplots[[nScatterplots]] <- target[[i]]
names(scatterplots)[nScatterplots] <- plotNames[i]
}
if(inherits(target[[i]], "l_hist")) {
nHistograms <- nHistograms + 1
histograms[[nHistograms]] <- target[[i]]
names(histograms)[nHistograms] <- plotNames[i]
}
if(inherits(target[[i]], "l_serialaxes")) {
nSerialAxes <- nSerialAxes + 1
serialAxes[[nSerialAxes]] <- target[[i]]
names(serialAxes)[nSerialAxes] <- plotNames[i]
}
}
nvar <- (-1 + sqrt(1 + 8 * nScatterplots)) / 2 + 1
showSerialAxes <- (nSerialAxes > 0)
showHistograms <- (nHistograms > 0)
if(showHistograms) {
histLocation <- if(nHistograms == (nvar - 1) * 2) "edge" else "diag"
if(histLocation == "edge") {
cells <- nvar + 1
} else {
cells <- nvar
}
} else {
cells <- nvar
}
layout_matrix <- matrix(rep(NA, (cells)^2), nrow = cells)
scatter_hist <- c(scatterplots, histograms)
for(i in 1:length(scatter_hist)) {
nameOfScatter_hist <- names(scatter_hist[i])
pos <- xy_layout(nameOfScatter_hist)
layout_matrix[pos$y, pos$x] <- i
}
if(showSerialAxes) {
serialAxesSpan <- floor(nvar/2)
# square space
for(i in 1:serialAxesSpan) {
for(j in 1:serialAxesSpan) {
layout_matrix[cells - serialAxesSpan + i, j] <- nScatterplots + nHistograms + 1
}
}
}
list(
nrow = cells,
ncol = cells,
layout_matrix = layout_matrix,
heights = rep(1, cells),
widths = rep(1, cells)
)
}
l_txtProgressBar <- function(min = 0, max, minLenToGivePb, style = 3, message = "") {
if(max > minLenToGivePb) {
message(message)
txtProgressBar(min = min, max = max, style = style)
} else return(NULL)
}
l_setTxtProgressBar <- function(pb, value) {
if(is.null(pb)) return(NULL)
setTxtProgressBar(pb, value)
}
l_close <- function(con, ...) {
if(is.null(con)) return(NULL)
close(con, ...)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.