#' @importFrom flipTransformations TextAsVector AsNumeric
#' @importFrom grDevices colorRamp
#' @importFrom verbs SumEachRow
scatterplotData <- function(chart.matrix,
type,
colors = NULL,
colors.reverse = FALSE,
colors.custom.color = NA,
colors.custom.gradient.start = NA,
colors.custom.gradient.end = NA,
colors.custom.palette = NA,
group.labels.text = "",
group.indices.text = "",
origin = FALSE,
transpose = FALSE,
rows.to.ignore = "",
cols.to.ignore = "",
legend.show = TRUE,
x.title = "",
y.title = "",
colorscale.variable = NULL,
logos = NULL)
{
ErrorIfNotEnoughData(chart.matrix)
not.na <- NULL
if (any(is.na(as.matrix(chart.matrix))) || (!is.null(colorscale.variable) && any(is.na(colorscale.variable))))
{
col.not.na <- 1:nrow(chart.matrix)
if (!is.null(colorscale.variable) && any(is.na(colorscale.variable)))
{
warning("Data points with missing values in the 'Colors' variable are hidden")
col.not.na <- !is.na(colorscale.variable)
}
warning("Data points with missing values have been omitted.")
not.na <- which(!is.na(SumEachRow(chart.matrix, remove.columns = NULL, remove.missing = FALSE)) & col.not.na)
if (length(not.na) == 0)
stop("No non-missing values to plot")
chart.matrix <- chart.matrix[not.na,,drop=FALSE]
if (!is.null(colorscale.variable))
colorscale.variable <- colorscale.variable[not.na]
if (!is.null(logos))
logos <- logos[not.na]
}
if (!is.null(group.indices.text) && group.indices.text[1] != "" && !is.null(colorscale.variable))
{
colorscale.variable <- NULL
warning("Color-scale variable ignored when groups are provided\n")
}
# Remove rows and columns to ignore
no.dimnames <- is.null(colnames(chart.matrix)) || colnames(chart.matrix)[1] == "chart.matrix"
if (is.null(dim(chart.matrix)) || ncol(chart.matrix) == 1)
{
chart.matrix <- cbind(chart.matrix, rep(0, length(chart.matrix)))
print(colnames(chart.matrix))
if (is.null(colnames(chart.matrix)) || colnames(chart.matrix)[1] == "chart.matrix")
no.dimnames <- TRUE
}
chart.matrix <- GetTidyTwoDimensionalArray(chart.matrix,
row.names.to.remove = rows.to.ignore,
column.names.to.remove = cols.to.ignore)
if (no.dimnames)
colnames(chart.matrix) <- NULL
pt.ord <- NULL
if (!is.null(group.labels.text) && any(group.labels.text != ""))
{
if (!is.null(group.indices.text) && any(group.indices.text != ""))
{
group.labels.text[group.labels.text == ""] <- "Undefined"
group.labels <- if (length(group.labels.text) > 1) group.labels.text
else TextAsVector(group.labels.text)
group.indices <- if (is.numeric(group.indices.text)) group.indices.text
else as.numeric(TextAsVector(group.indices.text))
if (!is.null(not.na))
group.indices <- group.indices[not.na]
if (length(group.labels) == 1 && length(unique(group.indices)) > 1)
stop(paste0("Only one group has been specified: ", group.labels[1]))
if (length(group.indices) != nrow(chart.matrix))
stop(paste0("The number of group indices (", length(group.indices), ") needs to equal the number of rows in the table (", nrow(chart.matrix), ")."))
permitted.indices <- 1:length(group.labels)
if (any(is.na(group.indices)) || !all(group.indices %in% permitted.indices))
stop(paste0("The group indices are not in the correct format."))
group <- group.labels[group.indices]
pt.ord <- order(group.indices)
}
else
stop("Group labels were provided but group indices are missing.")
}
else
{
if (!is.null(group.indices.text) && any(group.indices.text != ""))
stop("Group indices were provided but group labels are missing.")
else
group <- rep(" ", nrow(chart.matrix))
}
# order data points so that the color of groups are ordered
if (!is.null(pt.ord))
{
chart.matrix <- chart.matrix[pt.ord,]
logos <- logos[pt.ord]
group <- group[pt.ord]
# colorscale.variable not compatible with groups
}
# scale point sizes if needed
z.unscaled <- NULL
if (type == "Scatterplot" && ncol(chart.matrix) > 2)
{
# scaling for plotly scatterplots - sizemode="area" does not work
z.unscaled <- chart.matrix[,3]
sc <- chart.matrix[,3]
sc <- sqrt(abs(sc))
sc <- sc/max(sc, na.rm=T) * 50
if (any(is.na(sc)) || any(sc == 0))
warnings("Some observations have been hidden as they have missing or zero size.")
chart.matrix[,3] <- sc
}
if (is.null(colors))
colors <- "Default colors"
color.strings <- NULL
if (!is.null(colorscale.variable))
{
color.strings <- if (is.numeric(colorscale.variable)) FormatAsReal(as.numeric(colorscale.variable), 2)
else as.character(colorscale.variable)
colorscale.variable <- AsNumeric(colorscale.variable, binary=F)
}
num.colors <- if (!is.null(colorscale.variable)) 3
else length(unique(group))
colors <- ChartColors(number.colors.needed = num.colors,
given.colors = colors,
custom.color = colors.custom.color,
custom.gradient.start = colors.custom.gradient.start,
custom.gradient.end = colors.custom.gradient.end,
custom.palette = colors.custom.palette,
reverse = colors.reverse)
color.scale <- NULL
color.values <- NULL
if (!is.null(colorscale.variable) && type == "Scatterplot")
{
col.fun <- colorRamp(colors)
group <- rep(" ", nrow(chart.matrix))
c.tmp <- rgb(col.fun((0:5)/5), maxColorValue=255)
v.tmp <- seq(from=0, to=1, length=length(c.tmp))
color.scale <- mapply(function(a,b)c(a,b), a=v.tmp, b=c.tmp, SIMPLIFY=F)
color.values <- colorscale.variable
colors <- NULL
}
if (!is.null(colorscale.variable) && type != "Scatterplot")
{
col.fun <- colorRamp(colors)
group <- 1:length(colorscale.variable)
sc.vals <- (colorscale.variable - min(colorscale.variable, na.rm=T))/diff(range(colorscale.variable, na.rm=T))
sc.tmp <- col.fun(sc.vals)
colors <- rgb(sc.tmp, maxColorValue=255)
}
result <- list()
result$x <- if (transpose) AsNumeric(chart.matrix[, 2], binary=F) else AsNumeric(chart.matrix[, 1], binary=F)
result$y <- if (transpose) AsNumeric(chart.matrix[, 1], binary=F) else AsNumeric(chart.matrix[, 2], binary=F)
result$z <- if (ncol(chart.matrix) >= 3) AsNumeric(abs(chart.matrix[, 3]), binary=F) else NULL
result$z.unscaled <- z.unscaled
result$colors <- colors
result$color.scale <- color.scale
result$color.values <- color.values
result$color.strings <- color.strings
result$label <- if (!is.null(logos)) logos else rownames(chart.matrix)
result$label.alt <- rownames(chart.matrix)
result$group <- group
result$origin <- origin
result$legend.show <- is.null(colorscale.variable) && length(unique(result$group)) > 1 && legend.show
result$legend.bubbles.show <- ncol(chart.matrix) > 2
# Resolve axes labels if none specified manually
if (x.title == "" || length(x.title) == 0)
x.title <- colnames(chart.matrix)[1]
if (is.null(x.title) || x.title == "FALSE" || x.title == FALSE)
x.title <- ""
if (y.title == "" || length(y.title) == 0)
y.title <- colnames(chart.matrix)[2]
if (is.null(y.title) || y.title == "FALSE" || y.title == FALSE)
y.title <- ""
result$x.title <- if (transpose) y.title else x.title
result$y.title <- if (transpose) x.title else y.title
result
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.