Nothing
R/trianglePlot.R
In loa: Lattice Options and Add-Ins
Defines functions
triABCSquareGrid
triXY2ABC
triABC2XY.old
triABC2XY
triLimsReset
panel.trianglePlot
trianglePlot
Documented in
panel.trianglePlot
triABC2XY
triABCSquareGrid
trianglePlot
triLimsReset
triXY2ABC
#in development code
#[TBC - NUMBER] functions
#issue with trianglePlot
#axis misalignment in...
#trianglePlot(~Petal.Width+Sepal.Length+Sepal.Width, groups=iris$Species, data=iris)
#check trianglePlot
#is temp around the right way
# trianglePlot(ozone~wind*6+radiation+temperature*2, data=environmental)
#trianglePlot
#panel.trianglePlot
#panel.triangleByGroupPolygon
#panel.triangleKernelDensity
#panel.triangleSurfaceSmooth
#panel.trianglePlotFrame
#panel.trianglePlotGrid
#panel.trianglePlotAxes
#triLimsReset
#triABC2XY
#triXY2ABC
#triABCSquareGrid
#others now
#removed
###############################
#new trianglePlot
###############################
#this uses panelPal
#allows conditioning like in standard lattice
trianglePlot <- function(x, data = NULL, ..., ref.cols = TRUE){
#trianglePlot ver 0.2
#panelPal update
extra.args <- list(...)
if (is.logical(ref.cols))
ref.cols <- if (all(ref.cols))
c("darkgreen", "darkred", "darkblue")
else "black"
ref.cols <- rep(ref.cols, length.out=3)
extra.args <- listUpdate(list(x=x, data=data, formula.type="z~a0+b0+c0|cond",
coord.conversion=triABC2XY, panel=panel.trianglePlot, ref.cols=ref.cols),
extra.args)
do.call(loaPlot, extra.args)
}
##############################
#new panel.trianglePlot
##############################
#uses local.scales methods to handle axes
#local.scales.panel = panel.trianglePlotFrame
#data.panel = panel.loaPlot
#think about getting and adding to default settings in default data.panel?
#this would turn off key of key not set in data.panel?
panel.trianglePlot <-
function(x = NULL, y = NULL, a0 = NULL, b0 = NULL, c0 = NULL, ...,
loa.settings = FALSE, plot = TRUE, process = TRUE){
################
#this is based on panel.polarPlot
################
if(loa.settings)
return(list(group.args= c("col"),
zcase.args= c("pch"),
common.args = c("alim", "blim", "clim", "grid", "axes", "ticks", "annotation", "ref.cols"),
default.settings = list(local.scales = TRUE, local.scales.panel = panel.trianglePlotFrame,
data.panel = panel.loaPlot, grid = TRUE, axes = TRUE,
allowed.scales =c("a0", "b0", "c0"), disallowed.scales = c("x", "y"),
aspect = "loa.iso", reset.xylims = triLimsReset,
load.lists = c("grid", "axes", "ticks", "annotation"),
key.fun = "draw.loaPlotZKey")))
if(process){
###################
#to think about
###################
#make if missing
#x, y, a0, b0, c0,
#see below re polarplot code
if(!plot) return(list(x = x, y = y, a0=a0, b0=b0, c0=c0))
}
##
#######################
## the if missing would
## be like in polarPlot
#######################
##
## r <- x
## theta <- y
## x <- r * sin(pi * theta/180)
## y <- r * cos(pi * theta/180)
## if(!plot) return(list(x = x, y = y, r = r, theta = theta))
## }
if(plot){
extra.args <- listUpdate(list(...),
list(x = x, y = y, a0 = a0, b0=b0, c0=c0,
plot = plot, process = process))
###################
#might want to allow user to set this
#might want to be able to turn this off
#so not local.scales.panels
###################
###################
#might want to tidy
#the do.call
#data.panel does not
#need to be sent to
#data.panel...
###################
if ("groups" %in% names(extra.args) || "zcases" %in%
names(extra.args))
do.call(groupsAndZcasesPanelHandler, listUpdate(extra.args,
list(panel = extra.args$data.panel, plot = plot,
process = process), ignore = "grid"))
else do.call(extra.args$data.panel, listUpdate(extra.args,
list(), ignore = "grid"))
if (extra.args$local.scales)
if (is.function(extra.args$local.scales.panel)) {
do.call(extra.args$local.scales.panel, extra.args)
extra.args$grid <- NULL
}
}
}
#######################################################
#panel.triangleByGroupPolygon
#######################################################
panel.triangleByGroupPolygon <- function (x = NULL, y = NULL, a0 = NULL, b0 = NULL, c0 = NULL,
..., loa.settings = FALSE, plot = TRUE, process = TRUE)
{
#this is a temp solution
#it is very messy
#need to look at the alpha handling in plot section...
#also need to think about making a panel.loaPolygon which
# could fix a lot of this and give me more control of the
# polygons
if (loa.settings)
return(list(group.args = c("col"), zcase.args = c("pch"),
common.args = c("alim", "blim", "clim", "grid", "axes",
"ticks", "annotation", "ref.cols"), default.settings = list(local.scales = TRUE,
local.scales.panel = panel.trianglePlotFrame,
data.panel = panel.loaPlot, grid = TRUE, axes = TRUE,
allowed.scales = c("a0", "b0", "c0"), disallowed.scales = c("x",
"y"), aspect = "loa.iso", reset.xylims = triLimsReset,
load.lists = c("grid", "axes", "ticks", "annotation"),
key.fun = "draw.groupPlotKey")))
if (process) {
if (!plot)
return(list(x = x, y = y, a0 = a0, b0 = b0, c0 = c0))
}
if (plot) {
extra.args <- listUpdate(list(...), list(x = x, y = y,
a0 = a0, b0 = b0, c0 = c0, plot = plot, process = process))
if ("groups" %in% names(extra.args) || "zcases" %in%
names(extra.args))
do.call(groupsAndZcasesPanelHandler, listUpdate(extra.args,
list(panel = panel.polygon, plot = plot,
process = process), ignore = c("grid", "alpha", "alpha.regions")))
else {
#group/zcase handler assigns col
#but if no groups need to make sure it is set here
extra.args$col <- do.call(colHandler, extra.args)
do.call(panel.polygon, listUpdate(extra.args,
list(), ignore = c("grid", "alpha", "alpha.regions")))
}
if (extra.args$local.scales)
if (is.function(extra.args$local.scales.panel)) {
do.call(extra.args$local.scales.panel, extra.args)
extra.args$grid <- NULL
}
}
}
########################################################
#panel.triangleKernelDensity
########################################################
panel.triangleKernelDensity <- function (x = NULL, y = NULL, a0 = NULL, b0 = NULL, c0 = NULL,
..., loa.settings = FALSE, plot = TRUE, process = TRUE)
{
if (loa.settings)
return(list(group.args = c("col"), zcase.args = c("pch"),
common.args = c("alim", "blim", "clim", "grid", "axes",
"ticks", "annotation", "ref.cols"), default.settings = list(local.scales = TRUE,
local.scales.panel = panel.trianglePlotFrame,
data.panel = panel.loaLevelPlot, grid = TRUE,
axes = TRUE, allowed.scales = c("a0", "b0", "c0"),
disallowed.scales = c("x", "y"), aspect = "loa.iso",
reset.xylims = triLimsReset, load.lists = c("grid",
"axes", "ticks", "annotation"), n = 200, key.fun = "draw.loaColorKey",
key.raster = TRUE, isolate.col.regions = TRUE)))
if (process) {
if (!plot) {
extra.args <- list(...)
temp <- as.list(model.frame(data.frame(x = x, y = y,
a0 = a0, b0 = b0, c0 = c0)))
#tidy this bit
plotlist <- listUpdate(extra.args,
list(x = temp$x, y = temp$y, plot = FALSE, process = TRUE))
if(all(c("alim", "blim", "clim") %in% names(extra.args))){
#reset xlim and ylim for this
abc <- with(extra.args,
triABC2XY(a=c(alim[1], alim[2], alim[1]),
b=c(blim[1], blim[1], blim[2]),
c=c(clim[2], clim[1], clim[1])))
plotlist$xlim <- abc$x[c(1,3)]
plotlist$ylim <- abc$y[c(1,2)]
}
#but need to keep what is temp simple
#no xlim, ylim, etc.
#just x and y and z here
temp <- do.call(panel.kernelDensity, plotlist)
#make a b and c for new x y...
abc <- do.call(triXY2ABC, temp)
temp$a0 <- abc$a
temp$b0 <- abc$b
temp$c0 <- abc$c
#other option could be to strip out all not xyzabc here?
temp <- as.data.frame(temp)
#restrtict to range of triangle plot
temp <- if("alim" %in% names(extra.args))
temp[temp$a0 >= extra.args$alim[1] & temp$a0 <= extra.args$alim[2], ] else
temp[temp$a0 >= 0 & temp$a0 <= 1, ]
temp <- if("blim" %in% names(extra.args))
temp[temp$b0 >= extra.args$blim[1] & temp$b0 <= extra.args$blim[2], ] else
temp[temp$b0 >= 0 & temp$b0 <= 1, ]
temp <- if("clim" %in% names(extra.args))
temp[temp$c0 >= extra.args$clim[1] & temp$c0 <= extra.args$clim[2], ] else
temp[temp$c0 >= 0 & temp$c0 <= 1, ]
return(temp)
}
}
if (plot) {
extra.args <- listUpdate(list(...), list(x = x, y = y,
a0 = a0, b0 = b0, c0 = c0, plot = plot, process = process))
if ("groups" %in% names(extra.args) || "zcases" %in%
names(extra.args))
do.call(groupsAndZcasesPanelHandler, listUpdate(extra.args,
list(panel = extra.args$data.panel, plot = plot,
process = process), ignore = "grid"))
else do.call(extra.args$data.panel, listUpdate(extra.args,
list(), ignore = "grid"))
if (extra.args$local.scales)
if (is.function(extra.args$local.scales.panel)) {
do.call(extra.args$local.scales.panel, extra.args)
extra.args$grid <- NULL
}
}
}
#################################################
#panel.triangleSurfaceSmooth
#################################################
panel.triangleSurfaceSmooth <- function (x = NULL, y = NULL, z = NULL, a0 = NULL, b0 = NULL,
c0 = NULL, ..., loa.settings = FALSE, plot = TRUE, process = TRUE)
{
if (loa.settings)
return(list(group.args = c("col"), zcase.args = c("pch"),
common.args = c("alim", "blim", "clim", "grid", "axes",
"ticks", "annotation", "ref.cols"), default.settings = list(local.scales = TRUE,
local.scales.panel = panel.trianglePlotFrame,
data.panel = panel.loaLevelPlot, grid = TRUE,
axes = TRUE, allowed.scales = c("a0", "b0", "c0"),
disallowed.scales = c("x", "y"), aspect = "loa.iso",
reset.xylims = triLimsReset, load.lists = c("grid",
"axes", "ticks", "annotation"), n = 200, key.fun = "draw.loaColorKey",
key.raster = TRUE, isolate.col.regions = TRUE)))
if (process) {
if (!plot) {
#like panel.triangleKernelDensity
extra.args <- list(...)
temp <- as.list(model.frame(data.frame(x = x, y = y,
z = z, a0 = a0, b0 = b0, c0 = c0)))
plotlist <- listUpdate(extra.args,
list(x = temp$x, y = temp$y, z = temp$z, plot = FALSE, process = TRUE))
if(all(c("alim", "blim", "clim") %in% names(extra.args))){
#reset xlim and ylim for this
abc <- with(extra.args,
triABC2XY(a=c(alim[1], alim[2], alim[1]),
b=c(blim[1], blim[1], blim[2]),
c=c(clim[2], clim[1], clim[1])))
plotlist$xlim <- abc$x[c(1,3)]
plotlist$ylim <- abc$y[c(1,2)]
}
temp <- do.call(panel.surfaceSmooth, plotlist)
abc <- do.call(triXY2ABC, temp)
temp$a0 <- abc$a
temp$b0 <- abc$b
temp$c0 <- abc$c
temp <- as.data.frame(temp)
temp <- if("alim" %in% names(extra.args))
temp[temp$a0 >= extra.args$alim[1] & temp$a0 <= extra.args$alim[2], ] else
temp[temp$a0 >= 0 & temp$a0 <= 1, ]
temp <- if("blim" %in% names(extra.args))
temp[temp$b0 >= extra.args$blim[1] & temp$b0 <= extra.args$blim[2], ] else
temp[temp$b0 >= 0 & temp$b0 <= 1, ]
temp <- if("clim" %in% names(extra.args))
temp[temp$c0 >= extra.args$clim[1] & temp$c0 <= extra.args$clim[2], ] else
temp[temp$c0 >= 0 & temp$c0 <= 1, ]
return(temp)
}
}
if (plot) {
extra.args <- listUpdate(list(...), list(x = x, y = y,
z = z, a0 = a0, b0 = b0, c0 = c0, plot = plot, process = process))
if ("groups" %in% names(extra.args) || "zcases" %in%
names(extra.args))
do.call(groupsAndZcasesPanelHandler, listUpdate(extra.args,
list(panel = extra.args$data.panel, plot = plot,
process = process), ignore = "grid"))
else do.call(extra.args$data.panel, listUpdate(extra.args,
list(), ignore = "grid"))
if (extra.args$local.scales)
if (is.function(extra.args$local.scales.panel)) {
do.call(extra.args$local.scales.panel, extra.args)
extra.args$grid <- NULL
}
}
}
##############################
#panel.trianglePlotFrame
##############################
panel.trianglePlotFrame <-
function (..., grid = NULL, axes = NULL)
{
extra.args <- list(...)
#could tidy this?
if (isGood4LOA(grid)){
if(is.list(grid) && is.function(grid$panel))
do.call(grid$panel, listUpdate(extra.args, list(grid=grid), ignore="panel")) else
do.call(panel.trianglePlotGrid, listUpdate(extra.args, list(grid=grid), ignore="panel"))
}
if (isGood4LOA(axes)){
if(is.list(axes) && is.function(axes$panel))
do.call(axes$panel, listUpdate(extra.args, list(axes=axes), ignore="panel")) else
do.call(panel.trianglePlotAxes, listUpdate(extra.args, list(axes=axes), ignore="panel"))
}
}
############################
#panel.trianglePlotGrid
############################
panel.trianglePlotGrid <-
function (alim = NULL, blim = NULL, clim = NULL,
..., grid = TRUE, panel.scales = NULL)
{
extra.args <- list(...)
if (!is.list(panel.scales))
panel.scales <- list()
if (!is.list(grid))
grid <- list()
panel.scales <- listUpdate(list(draw = TRUE, arrows = FALSE,
lty=3,
tick.number = 5, abbreviate = FALSE, minlength = 4, tck = 1,
col= "lightgrey", cex = 0.8), panel.scales)
grid <- do.call(listLoad, listUpdate(grid, list(load="a0")))
grid <- do.call(listLoad, listUpdate(grid, list(load="b0")))
grid <- do.call(listLoad, listUpdate(grid, list(load="c0")))
temp <- list(a0=list(col=extra.args$ref.cols[1]),
b0=list(col=extra.args$ref.cols[2]),
c0=list(col=extra.args$ref.cols[3]))
if(is.null(grid$col)) grid <- listUpdate(temp, grid)
grid.pars <- getPlotArgs("axis.line", local.resets = panel.scales,
user.resets = grid, elements = c("a0", "b0", "c0"),
is.scale=TRUE, defaults.only = FALSE)
at.loc <- function(par, lim){
temp <- listUpdate(list(tick.number=5), par, use=c("at", "tick.number"))
temp <- if (!is.null(temp$at)) temp$at else
pretty(lim, temp$tick.number)
#remove any out of range
#if range too big
temp[temp >= min(lim, na.rm=T) & temp <= max(lim, na.rm=T)]
}
#a axis
a.at <- at.loc(grid.pars$a, alim)
temp <- function(x) {
a1 <- triABC2XY(c(x, x), c(blim[1], blim[2] - (x - alim[1])),
c(clim[2] - (x - alim[1]), clim[1]))
if (isGood4LOA(grid.pars$a)){
grid.pars$a$x <- a1$x
grid.pars$a$y <- a1$y
do.call(llines, grid.pars$a)
}
}
for (i in a.at) temp(i)
#b axis
b.at <- at.loc(grid.pars$b, blim)
temp <- function(x) {
b1 <- triABC2XY(c(alim[1], alim[2] - (x - blim[1])),
c(x, x), c(clim[2] - (x - blim[1]), clim[1]))
if (isGood4LOA(grid.pars$b)){
grid.pars$b$x <- b1$x
grid.pars$b$y <- b1$y
do.call(llines, grid.pars$b)
}
}
for (i in b.at) temp(i)
#c axis
c.at <- at.loc(grid.pars$c, clim)
temp <- function(x) {
c1 <- triABC2XY(c(alim[1], alim[2] - (x - clim[1])),
c(blim[2] - (x - clim[1]), blim[1]), c(x, x))
if (isGood4LOA(grid.pars$c)){
grid.pars$c$x <- c1$x
grid.pars$c$y <- c1$y
do.call(llines, grid.pars$c)
}
}
for (i in c.at) temp(i)
}
############################
#panel.trianglePlotAxes
############################
panel.trianglePlotAxes <-
function (alim = NULL, blim = NULL, clim = NULL, ...,
axes = TRUE, ticks=TRUE, annotation=TRUE,
panel.scales = NULL)
{
#reposition a and b labs so parallel to axes
#look and management of font size in local labels handler
#
extra.args <- list(...)
alab <- if(is.null(extra.args$alab)) extra.args$a0lab else extra.args$alab
blab <- if(is.null(extra.args$blab)) extra.args$b0lab else extra.args$blab
clab <- if(is.null(extra.args$clab)) extra.args$c0lab else extra.args$clab
if (!is.list(panel.scales))
panel.scales <- list()
if (!is.list(axes))
axes <- list()
# if (!is.list(ticks))
# ticks <- list()
# if (!is.list(annotation))
# annotation <- list()
temp <- prod(dim(trellis.currentLayout()),na.rm=T)
text.cex <- 1
if(temp>1) text.cex <- 0.8
if(temp>3) text.cex <- 0.7
if(temp>3) text.cex <- 0.6
if(temp>9) text.cex <- 0.5
temp <- list(a0=list(col=extra.args$ref.cols[1]),
b0=list(col=extra.args$ref.cols[2]),
c0=list(col=extra.args$ref.cols[3]))
axes <- do.call(listLoad, listUpdate(axes, list(load="a0")))
axes <- do.call(listLoad, listUpdate(axes, list(load="b0")))
axes <- do.call(listLoad, listUpdate(axes, list(load="c0")))
if(isGood4LOA(ticks)){
if(!is.list(ticks)) ticks <- list()
ticks <- do.call(listLoad, listUpdate(ticks, list(load="a0")))
ticks <- do.call(listLoad, listUpdate(ticks, list(load="b0")))
ticks <- do.call(listLoad, listUpdate(ticks, list(load="c0")))
if(is.null(ticks$col)) ticks <- listUpdate(temp, ticks)
} else ticks <- list(col=NA)
if(isGood4LOA(annotation)){
if(!is.list(annotation)) annotation <- list()
annotation <- do.call(listLoad, listUpdate(annotation, list(load="a0")))
annotation <- do.call(listLoad, listUpdate(annotation, list(load="b0")))
annotation <- do.call(listLoad, listUpdate(annotation, list(load="c0")))
if(is.null(annotation$cex)) annotation$cex <- (text.cex*0.8)
if(is.null(annotation$col)) annotation <- listUpdate(temp, annotation)
} else annotation <- list(col=NA)
# panel.scales <- listUpdate(list(draw = TRUE, arrows = FALSE,
# tick.number = 5, abbreviate = FALSE, minlength = 4, tck = 1,
# col = "red", col.line = 1, cex = 0.8), panel.scales)
axis.loc <- function(n, lim) (n * (max(lim, na.rm = TRUE) -
min(lim, na.rm = TRUE))) + min(lim, na.rm = TRUE)
at.loc <- function(par, axes, ticks, lim){
temp <- listUpdate(par, axes, use=c("at", "tick.number"))
temp <- listUpdate(temp, ticks, use=c("at", "tick.number"))
if(!is.null(temp$at)) temp$at else pretty(lim, temp$tick.number)
}
axes.pars <- getPlotArgs(default.as = "axis.line", source = panel.scales,
elements = c("a0", "b0", "c0"), is.scales = TRUE, user.resets = axes)
tick.pars <- getPlotArgs(default.as = "axis.line", source = panel.scales,
elements = c("a0", "b0", "c0"), is.scales = TRUE, user.resets = ticks)
ann.pars <- getPlotArgs(default.as = "axis.text", source = panel.scales,
elements = c("a0", "b0", "c0"), is.scales = TRUE, user.resets = annotation)
#this fixes the current issue with getPlotArgs
ann.pars$a0 <- listUpdate(annotation, ann.pars$a0, ignore.a=c("a0", "b0", "c0"))
ann.pars$b0 <- listUpdate(annotation, ann.pars$b0, ignore.a=c("a0", "b0", "c0"))
ann.pars$c0 <- listUpdate(annotation, ann.pars$c0, ignore.a=c("a0", "b0", "c0"))
#need to fix this
###currently changes to ticks but not others
###this gives us full axes control but
###using n0 axis name not n
###print(tick.pars)
panel.scales$a <- listUpdate(list(at = at.loc(list(tick.number=5), axes.pars$a, tick.pars$a, alim)),
panel.scales$a)
# tick.pars$a$isGood4LOA <- TRUE
# ann.pars$a$isGood4LOA <- TRUE
temp <- triABC2XY(c(axis.loc(0.5, alim), axis.loc(0.5, alim),
axis.loc(0, alim), axis.loc(1, alim)), c(axis.loc(0.1,
blim), axis.loc(0, blim), axis.loc(0, blim), axis.loc(0,
blim)), c(axis.loc(0.4, clim), axis.loc(0.5, clim), axis.loc(1,
clim), axis.loc(0, clim)))
panel.localScale(panel.scale = panel.scales$a, x.loc = temp$x[3:4],
y.loc = temp$y[3:4], lim = alim, x.offset = temp$x[2] -
temp$x[1], y.offset = temp$y[2] - temp$y[1], axis = axes.pars$a0,
ticks=tick.pars$a0, annotation=ann.pars$a0)
# ltext(x = temp$x[1] - (3 * (temp$x[2] - temp$x[1])) - (3 *
# (temp$x[1] - temp$x[3])), y = temp$y[1] + (2 * (y.offset = temp$y[2] -
# temp$y[1])), alab, adj = c(1, 0.5), srt=60)
ltext(x = temp$x[1] + (4 * (temp$x[2] - temp$x[1])), y = temp$y[1] +
(3 * (y.offset = temp$y[2] - temp$y[1])), alab, adj = c(0.5,
0.5), srt=60, cex = text.cex)
panel.scales$b <- listUpdate(list(at = at.loc(list(tick.number=5), axes.pars$b, tick.pars$b, blim)),
panel.scales$b)
# tick.pars$b$isGood4LOA <- TRUE
# ann.pars$b$isGood4LOA <- TRUE
temp <- triABC2XY(c(axis.loc(0.4, alim), axis.loc(0.5, alim),
axis.loc(1, alim), axis.loc(0, alim)), c(axis.loc(0.5,
blim), axis.loc(0.5, blim), axis.loc(0, blim), axis.loc(1,
blim)), c(axis.loc(0.1, clim), axis.loc(0, clim), axis.loc(0,
clim), axis.loc(0, clim)))
panel.localScale(panel.scale = panel.scales$b, x.loc = temp$x[3:4],
y.loc = temp$y[3:4], lim = blim, x.offset = temp$x[2] -
temp$x[1], y.offset = temp$y[2] - temp$y[1], axis = axes.pars$b0,
ticks = tick.pars$b0, annotation = ann.pars$b0)
ltext(x = temp$x[1] + (4 * (temp$x[2] - temp$x[1])), y = temp$y[1] +
(3 * (y.offset = temp$y[2] - temp$y[1])), blab, adj = c(0.5,
0.5), srt=300, cex = text.cex)
panel.scales$c <- listUpdate(list(at = at.loc(list(tick.number=5), axes.pars$c, tick.pars$c, clim)),
panel.scales$c)
# tick.pars$c$isGood4LOA <- TRUE
# ann.pars$c$isGood4LOA <- TRUE
temp <- triABC2XY(c(axis.loc(0.1, alim), axis.loc(0, alim),
axis.loc(0, alim), axis.loc(0, alim)), c(axis.loc(0.4,
blim), axis.loc(0.5, blim), axis.loc(1, blim), axis.loc(0,
blim)), c(axis.loc(0.5, clim), axis.loc(0.5, clim), axis.loc(0,
clim), axis.loc(1, clim)))
panel.localScale(panel.scale = panel.scales$c, x.loc = temp$x[3:4],
y.loc = temp$y[3:4], lim = clim, x.offset = temp$x[2] -
temp$x[1], y.offset = temp$y[2] - temp$y[1], axis = axes.pars$c0,
ticks = tick.pars$c0, annotation = ann.pars$c0)
ltext(x = temp$x[2], y = temp$y[1] + (3 * (y.offset = temp$y[2] -
temp$y[1])), clab, adj = c(0.5, 0.5), cex=text.cex)
}
#############################
#############################
##data handlers
#############################
#############################
###############################
#triLimsReset
###############################
triLimsReset <-
function(ans){
#what is not a, b, clim values
#does function in preprocess make them?
#messy
temp <- ans$panel.args.common
temp <- triABC2XY(a = c(temp$alim[1], temp$alim[1], temp$alim[2]),
b = c(temp$blim[1], temp$blim[2], temp$blim[1]), c = c(temp$clim[2],
temp$clim[1], temp$clim[1]), verbose = FALSE)
xlim <- range(temp$x, na.rm = TRUE)
ylim <- range(temp$y, na.rm = TRUE)
ans$panel.args.common$xlim <- xlim
ans$x.limits <- xlim
ans$panel.args.common$ylim <- ylim
ans$y.limits <- ylim
temp <- function(lim, q1, q2) {
if (diff(lim) == 0)
lim + q1
else lim + c(-(diff(lim)/q2[1]), (diff(lim)/q2[2]))
}
#messy
extra.args <- ans$panel.args.common
alab <- if(is.null(extra.args$alab)) extra.args$a0lab else extra.args$alab
blab <- if(is.null(extra.args$blab)) extra.args$b0lab else extra.args$blab
clab <- if(is.null(extra.args$clab)) extra.args$c0lab else extra.args$clab
if (is.null(clab)) {
extra.args$xlim <- temp(extra.args$xlim, c(-0.5, 0.5),
c(5, 5))
extra.args$ylim <- temp(extra.args$ylim, c(-0.5, 0.5),
c(5, 5))
}
else if (is.character(clab) && clab == "") {
extra.args$xlim <- temp(extra.args$xlim, c(-0.5, 0.5),
c(5, 5))
extra.args$ylim <- temp(extra.args$ylim, c(-0.5, 0.5),
c(5, 5))
}
else {
extra.args$xlim <- temp(extra.args$xlim, c(-0.5, 0.5),
c(5, 5))
extra.args$ylim <- temp(extra.args$ylim, c(-0.3, 0.5),
c(3, 5))
}
ans$panel.args.common <- extra.args
ans$x.limits <- ans$panel.args.common$xlim
ans$y.limits <- ans$panel.args.common$ylim
ans
}
##############################
##############################
##triABC2XY
##############################
##############################
triABC2XY <- function(a, b=NULL, c=NULL, ..., force.abc=TRUE,
if.na="remove.row", if.neg="remove.row", verbose=FALSE){
#############
#setup
#############
#extra.args
extra.args <- list(...)
#############
#new
#############
#if a,b,c not there
#use a0, b0, and c0 if there
if(missing(a) && "a0" %in% names(extra.args)) a <- extra.args$a0
if(is.null(b) && "b0" %in% names(extra.args)) b <- extra.args$b0
if(is.null(c) && "c0" %in% names(extra.args)) c <- extra.args$c0
#############
#
#make a,b,c a data.frame
################
#could standardise this next bit and front end of triXY2ABC
#and make common function dataHandler
#could also put the logs in there
################
data.abc <- if(is.data.frame(a)) a else
if(is.list(a)) as.data.frame(a) else
if(is.vector(a)) data.frame(a=a) else
stop("unable to handle supplied data", call. = FALSE)
###################
#possible issue if
#a shorter than b,c
###################
if(is.vector(b))
data.abc$b <- if(length(b) < nrow(data.abc))
rep(b, ceiling(nrow(data.abc)/length(b)))[1:nrow(data.abc)] else
b[1:nrow(data.abc)]
if(is.vector(c))
data.abc$c <- if(length(c) < nrow(data.abc))
rep(c, ceiling(nrow(data.abc)/length(c)))[1:nrow(data.abc)] else
c[1:nrow(data.abc)]
#check dim
if(ncol(data.abc) < 3)
stop("insufficient data for 'abc' assignment", call. = FALSE)
#force.abc/rescale
temp <- data.abc[,1:3]
if(force.abc){
if("a" %in% names(data.abc)) temp[,1] <- data.abc$a
if("b" %in% names(data.abc)) temp[,2] <- data.abc$b
if("c" %in% names(data.abc)) temp[,3] <- data.abc$c
}
data.abc <- temp
abc.status <- rep(0, nrow(data.abc)) #abc.status
###########
#if.neg and if.na
###########
##############
#need keep.as.is catcher
##############
na.log <- apply(data.abc, 1, function(x) any(is.na(x))) #na
neg.log <- apply(data.abc, 1, function(x) any(!is.na(x) & x<0)) #negs
if(any(na.log)) {
if(if.na == "remove.row")
data.abc[na.log, 1:3] <- c(NA,NA,NA)
if(if.na == "make.zero")
data.abc[is.na(data.abc)] <- 0
}
if(any(neg.log)) {
if(if.neg == "remove.row")
data.abc[neg.log, 1:3] <- c(NA,NA,NA)
if(if.neg == "make.zero")
data.abc[data.abc<0] <- 0
if(if.neg == "rescale.col")
if(nrow(data.abc)==1)
data.abc[data.abc<0] <- 0 else
data.abc <- as.data.frame(apply(data.abc, 2, function(x)
if(min(x, na.rm=TRUE)<0) x-min(x, na.rm=TRUE) else x))
}
#############
#below needs documenting in help
#############
#abc 2 prop(abc)
#function used again later
prop.abc <- function(d){
temp <- d[,1] + d[,2] + d[,3]
d/temp
}
data.abc <- prop.abc(data.abc)
temp <- apply(data.abc, 2, function(x)
diff(range(x, na.rm=TRUE)))
abc.bord <- if(all(is.na(temp))) 0.05 else
max(temp, na.rm=TRUE) * 0.1
if(abc.bord <= 0) abc.bord <- 0.05
#abc.bord is plot border
lims <- data.frame(a=c(0,1),b=c(0,1),c=c(0,1))
#shrink c
temp <- seq(lims[1,3], lims[2,3], length.out=20)
#temp <- pretty(c(lims[1,3], lims[2,3]), 10)
temp <- temp[temp < min(data.abc[,3]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,3]
lims[1,3] <- lims[1,3]+temp
lims[2,1] <- lims[2,1]-temp
lims[2,2] <- lims[2,2]-temp
#shrink b
temp <- seq(lims[1,2], lims[2,2], length.out=20)
#temp <- pretty(c(lims[1,2], lims[2,2]), 10)
temp <- temp[temp<min(data.abc[,2]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,2]
lims[1,2] <- lims[1,2]+temp
lims[2,1] <- lims[2,1]-temp
lims[2,3] <- lims[2,3]-temp
#shrink a
temp <- seq(lims[1,1], lims[2,1], length.out=20)
#temp <- pretty(c(lims[1,1], lims[2,1]), 10)
temp <- temp[temp<min(data.abc[,1]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,1]
lims[1,1] <- lims[1,1]+temp
lims[2,2] <- lims[2,2]-temp
lims[2,3] <- lims[2,3]-temp
#shrink c
temp <- seq(lims[1,3], lims[2,3], length.out=20)
#temp <- pretty(c(lims[1,3], lims[2,3]), 10)
temp <- temp[temp < min(data.abc[,3]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,3]
lims[1,3] <- lims[1,3]+temp
lims[2,1] <- lims[2,1]-temp
lims[2,2] <- lims[2,2]-temp
#shrink b
temp <- seq(lims[1,2], lims[2,2], length.out=20)
#temp <- pretty(c(lims[1,2], lims[2,2]), 10)
temp <- temp[temp<min(data.abc[,2]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,2]
lims[1,2] <- lims[1,2]+temp
lims[2,1] <- lims[2,1]-temp
lims[2,3] <- lims[2,3]-temp
#shrink a
temp <- seq(lims[1,1], lims[2,1], length.out=20)
#temp <- pretty(c(lims[1,1], lims[2,1]), 10)
temp <- temp[temp<min(data.abc[,1]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,1]
lims[1,1] <- lims[1,1]+temp
lims[2,2] <- lims[2,2]-temp
lims[2,3] <- lims[2,3]-temp
ans <- list(x = data.abc[,2]+(0.5*data.abc[,1]),
y = ((data.abc[,1]*0.866)*1.1)/1, #confirm 1.1
alim = lims[,1], blim = lims[,2], clim = lims[,3])
if(!verbose) return(ans)
#full return
#may want to rethink structure
#re passing a,b,c to xyplot.formula...
#check for out of range values
##compare with lims
oor.log <- rep(FALSE, nrow(data.abc))
oor.log <- ifelse(data.abc[,1] < min(lims[,1], na.rm=TRUE) |
data.abc[,1] > max(lims[,1], na.rm=TRUE), TRUE, oor.log)
oor.log <- ifelse(data.abc[,2] < min(lims[,2], na.rm=TRUE) |
data.abc[,2] > max(lims[,2], na.rm=TRUE), TRUE, oor.log)
oor.log <- ifelse(data.abc[,3] < min(lims[,3], na.rm=TRUE) |
data.abc[,3] > max(lims[,3], na.rm=TRUE), TRUE, oor.log)
#catch na's
oor.log[is.na(oor.log)]<- FALSE
listUpdate(ans, list(a=data.abc[,1], b=data.abc[,2], c=data.abc[,3],
report = list(nas=na.log, negs=neg.log, oor=oor.log)))
}
triABC2XY.old <- function(a, b=NULL, c=NULL, ..., force.abc=TRUE,
if.na="remove.row", if.neg="remove.row", verbose=FALSE){
#############
#setup
#############
#extra.args
extra.args <- list(...)
#############
#new
#############
#if a,b,c not there
#use a0, b0, and c0 if there
if(missing(a) && "a0" %in% names(extra.args)) a <- extra.args$a0
if(is.null(b) && "b0" %in% names(extra.args)) b <- extra.args$b0
if(is.null(c) && "c0" %in% names(extra.args)) c <- extra.args$c0
#############
#
#make a,b,c a data.frame
################
#could standardise this next bit and front end of triXY2ABC
#and make common function dataHandler
#could also put the logs in there
################
data.abc <- if(is.data.frame(a)) a else
if(is.list(a)) as.data.frame(a) else
if(is.vector(a)) data.frame(a=a) else
stop("unable to handle supplied data", call. = FALSE)
###################
#possible issue if
#a shorter than b,c
###################
if(is.vector(b))
data.abc$b <- if(length(b) < nrow(data.abc))
rep(b, ceiling(nrow(data.abc)/length(b)))[1:nrow(data.abc)] else
b[1:nrow(data.abc)]
if(is.vector(c))
data.abc$c <- if(length(c) < nrow(data.abc))
rep(c, ceiling(nrow(data.abc)/length(c)))[1:nrow(data.abc)] else
c[1:nrow(data.abc)]
#check dim
if(ncol(data.abc) < 3)
stop("insufficient data for 'abc' assignment", call. = FALSE)
#force.abc/rescale
temp <- data.abc[,1:3]
if(force.abc){
if("a" %in% names(data.abc)) temp[,1] <- data.abc$a
if("b" %in% names(data.abc)) temp[,2] <- data.abc$b
if("c" %in% names(data.abc)) temp[,3] <- data.abc$c
}
data.abc <- temp
abc.status <- rep(0, nrow(data.abc)) #abc.status
###########
#if.neg and if.na
###########
##############
#need keep.as.is catcher
##############
na.log <- apply(data.abc, 1, function(x) any(is.na(x))) #na
neg.log <- apply(data.abc, 1, function(x) any(!is.na(x) & x<0)) #negs
if(any(na.log)) {
if(if.na == "remove.row")
data.abc[na.log, 1:3] <- c(NA,NA,NA)
if(if.na == "make.zero")
data.abc[is.na(data.abc)] <- 0
}
if(any(neg.log)) {
if(if.neg == "remove.row")
data.abc[neg.log, 1:3] <- c(NA,NA,NA)
if(if.neg == "make.zero")
data.abc[data.abc<0] <- 0
if(if.neg == "rescale.col")
if(nrow(data.abc)==1)
data.abc[data.abc<0] <- 0 else
data.abc <- as.data.frame(apply(data.abc, 2, function(x)
if(min(x, na.rm=TRUE)<0) x-min(x, na.rm=TRUE) else x))
}
#############
#below needs documenting in help
#############
#abc 2 prop(abc)
#function used again later
prop.abc <- function(d){
temp <- d[,1] + d[,2] + d[,3]
d/temp
}
data.abc <- prop.abc(data.abc)
################################
################################
##############
#lim forcings
##############
##################
#following based on ade4/Daniel Chessel method
#################
##selection of sensible lim range
#could move this to separate/as data handlers
#
#lim forcings
if(is.null(extra.args$lims)){
lims <- apply(data.abc, 2, range, na.rm = TRUE, finite = TRUE)
lims[1,] <- (floor(lims[1,]/0.1))/10
lims[2,] <- (floor(lims[2,]/0.1) + 1)/10
} else {
lims <- as.data.frame(matrix(rep(extra.args$lims[1:2], 3),
ncol = 3, nrow = 2))
}
if(!is.null(extra.args$alim))
lims[,1] <- extra.args$alim
if(!is.null(extra.args$blim))
lims[,2] <- extra.args$blim
if(!is.null(extra.args$clim))
lims[,3] <- extra.args$clim
if(!is.null(extra.args$abc.mins))
lims[1,] <- extra.args$abc.mins
if(!is.null(extra.args$abc.maxs))
lims[2,] <- extra.args$abc.maxs
#stop the bad
lims[1,][lims[1,] < 0] <- 0
lims[2,][lims[2,] > 1] <- 1
#lims range
#ade4 method
##############
#rethink this?
##############
lim.lite <-function(lims){
temp <- lims[2,] - lims[1,]
temp2 <- max(temp)
if (!all(temp == temp2)) {
for (j in 1:3) {
k <- temp2 - temp[j]
while (k > 0) {
if ((k > 0) & (lims[2,j] < 1)) {
lims[2,j] <- lims[2,j] + 0.1
k <- k - 1
}
if ((k > 0) & (lims[1,j] > 0)) {
lims[1,j] <- lims[1,j] - 0.1
k <- k - 1
}
}
}
}
cal <- matrix(0, 9, 3)
cal[1, 1] <- lims[1,1]
cal[1, 2] <- lims[1,2]
cal[1, 3] <- 1 - cal[1, 1] - cal[1, 2]
cal[2, 1] <- lims[1,1]
cal[2, 2] <- lims[2,2]
cal[2, 3] <- 1 - cal[2, 1] - cal[2, 2]
cal[3, 1] <- lims[2,1]
cal[3, 2] <- lims[1,2]
cal[3, 3] <- 1 - cal[3, 1] - cal[3, 2]
cal[4, 1] <- lims[1,1]
cal[4, 3] <- lims[1,3]
cal[4, 2] <- 1 - cal[4, 1] - cal[4, 3]
cal[5, 1] <- lims[1,1]
cal[5, 3] <- lims[2,3]
cal[5, 2] <- 1 - cal[5, 1] - cal[5, 3]
cal[6, 1] <- lims[2,1]
cal[6, 3] <- lims[1,3]
cal[6, 2] <- 1 - cal[6, 1] - cal[6, 3]
cal[7, 2] <- lims[1,2]
cal[7, 3] <- lims[1,3]
cal[7, 1] <- 1 - cal[7, 2] - cal[7, 3]
cal[8, 2] <- lims[1,2]
cal[8, 3] <- lims[2,3]
cal[8, 1] <- 1 - cal[8, 2] - cal[8, 3]
cal[9, 2] <- lims[2,2]
cal[9, 3] <- lims[1,3]
cal[9, 1] <- 1 - cal[9, 2] - cal[9, 3]
lims[1,] <- apply(cal, 2, min)
lims[1,] <- round(lims[1,], digits = 4)
lims[2,] <- apply(cal, 2, max)
lims[2,] <- round(lims[2,], digits = 4)
###################
#new bit
#bad lims
temp <- lims[2,] -lims[1,]
if(length(unique(temp))>1)
lims[2,] <- lims[1,] + max(temp, na.rm=TRUE)
#####################
#stop the bad
lims[1,][lims[1,] < 0] <- 0
lims[2,][lims[2,] > 1] <- 1
lims
}
lims <- lim.lite(lims)
#check if next bit needed
temp <- lims[2,] - lims[1,]
temp2 <- max(temp)
if (!all(temp == temp2))
lims <- lim.lite(lims)
if (!all(temp == temp2))
lims <- lim.lite(lims)
################################
################################
#check for out of range values
##compare with lims
oor.log <- rep(FALSE, nrow(data.abc))
oor.log <- ifelse(data.abc[,1] < min(lims[,1], na.rm=TRUE) |
data.abc[,1] > max(lims[,1], na.rm=TRUE), TRUE, oor.log)
oor.log <- ifelse(data.abc[,2] < min(lims[,2], na.rm=TRUE) |
data.abc[,2] > max(lims[,2], na.rm=TRUE), TRUE, oor.log)
oor.log <- ifelse(data.abc[,3] < min(lims[,3], na.rm=TRUE) |
data.abc[,3] > max(lims[,3], na.rm=TRUE), TRUE, oor.log)
#catch na's
oor.log[is.na(oor.log)]<- FALSE
data.abc[oor.log, 1:3] <- c(NA,NA,NA)
#################
##following based on Mu Zhu,
##Statistical Computing and Graphics 19,1, 2008
#################
#eta <- 0.08
#anchor <- diag(3)
#alpha1 <- c(1, -1, 0)/sqrt(2)
#alpha2 <- c(-0.5, -0.5, 1)/sqrt(1.5)
#vert.x <- anchor %*% alpha1
#vert.y <- anchor %*% alpha2
#x <- as.matrix(data.abc) * alpha1
#y <- as.matrix(data.abc) * alpha2
#ans <- list(x = x,
# y = y,
# alim = lims[,1], blim = lims[,2], clim = lims[,3])
##################
#following based on ade4/Daniel Chessel method
#################
##with this abc -> xy scaling is local so triangle size remains constant
##if this is adopted we could simplify panel... functions
##rescale axis
##rescale.axis <- function(n, lim)
## (n - lim[1])/(lim[2]-lim[1])
##temp <- data.abc
##temp[,1] <- rescale.axis(temp[,1], lims[,1])
##temp[,2] <- rescale.axis(temp[,2], lims[,2])
##temp[,3] <- rescale.axis(temp[,3], lims[,3])
##temp <- prop.abc(temp)
#basic return x,y a/b/clim
##ans <- list(x = (temp[,1] - temp[,3])/sqrt(2),
## y = (2 * temp[,2] - temp[,1] - temp[,3])/sqrt(6),
## alim = lims[,1], blim = lims[,2], clim = lims[,3])
##alternative method from Leic method?
##with this abc -> xy scaling fixed and triangle size changes
##with this panel... stay as is but triXY2ABC is greatly simplified
##also lim setting much less flexible
ans <- list(x = data.abc[,2]+(0.5*data.abc[,1]),
y = ((data.abc[,1]*0.867)*1.1)/1, #confirm 1.1
alim = lims[,1], blim = lims[,2], clim = lims[,3])
if(!verbose) return(ans)
#full return
#may want to rethink structure
#re passing a,b,c to xyplot.formula...
listUpdate(ans, list(a=data.abc[,1], b=data.abc[,2], c=data.abc[,3],
report = list(nas=na.log, negs=neg.log, oor=oor.log)))
}
##############################
##############################
##triXY2ABC
##############################
##############################
triXY2ABC <- function(x, y=NULL, ..., force.xy=TRUE, verbose=FALSE){
#############
#setup
#############
#make xy a data.frame
data.xy <- if(is.data.frame(x)) a else
if(is.list(x)) as.data.frame(x) else
if(is.vector(x)) data.frame(x=x) else
stop("unable to handle supplied data", call. = FALSE)
###################
#possible issue if
#x shorter than y - as above
###################
#need a lim checker/out of range handler
#need
if(is.vector(y))
data.xy$y <- if(length(y) < nrow(data.xy))
rep(y, ceiling(nrow(data.xy)/length(y)))[1:nrow(data.xy)] else
y[1:nrow(data.xy)]
#check dim
if(ncol(data.xy) < 2)
stop("insufficient data for 'xy' assignment", call. = FALSE)
#force.abc/rescale
temp <- data.xy[,1:2]
if(force.xy){
if("x" %in% names(data.xy)) temp[,1] <- data.xy$x
if("y" %in% names(data.xy)) temp[,2] <- data.xy$y
}
data.xy <- temp
a <- data.xy[,2]/(1.1 *0.866) * 1 #comfirm 1.1
b <- (data.xy[,1] - (a * 0.5))
c <- 1 - (a+b)
ans <- list(a=a, b=b, c=c)
if(!verbose) return(ans)
listUpdate(ans, list(x=data.xy[,1], y=data.xy[,2]))
}
#################################################
#triABCSquareGrid
#################################################
#needs work
triABCSquareGrid <- function(a, b = NULL, c = NULL, ..., n=100){
#currently this expected three data series
#but overrides if a/b/clim are present
#tested with
#ans <- triABCSquareGrid(alim=c(0,1), blim=c(0,1), clim=c(0,1), n=20)
# with(ans, trianglePlot(a*b*c~a+b+c))
#maybe test with a/b/c inputs later.
extra.args <- list(...)
if(all(c("alim", "blim", "clim") %in% names(extra.args))){
#use the lims to make grid
a <- c(min(extra.args$alim, na.rm=TRUE), max(extra.args$alim, na.rm=TRUE), min(extra.args$alim, na.rm=TRUE))
b <- c(min(extra.args$blim, na.rm=TRUE), min(extra.args$blim, na.rm=TRUE), max(extra.args$blim, na.rm=TRUE))
c <- c(max(extra.args$clim, na.rm=TRUE), min(extra.args$clim, na.rm=TRUE), min(extra.args$clim, na.rm=TRUE))
} else {
extra.args <- listUpdate(list(alim=c(0,1), blim=c(0,1), clim=c(0,1)), extra.args)
}
xy <- triABC2XY(a, b, c)
x <- seq(min(xy$x, na.rm=TRUE), max(xy$x, na.rm=TRUE), length.out=n)
y <- seq(min(xy$y, na.rm=TRUE), max(xy$y, na.rm=TRUE), length.out=n)
grd <- list(x=rep(x, each=length(y)), y=rep(y, length(x)))
grd <- data.frame(as.data.frame(do.call(triXY2ABC, grd)), as.data.frame(grd))
#tidy grd
grd <- grd[grd[,1] >= min(extra.args$alim, na.rm=TRUE) & grd[,1] <= max(extra.args$alim, na.rm=TRUE),]
grd <- grd[grd[,2] >= min(extra.args$blim, na.rm=TRUE) & grd[,2] <= max(extra.args$blim, na.rm=TRUE),]
grd <- grd[grd[,3] >= min(extra.args$clim, na.rm=TRUE) & grd[,3] <= max(extra.args$clim, na.rm=TRUE),]
#drop x and y?
grd <- grd[c("a", "b", "c")]
#make unique?
as.list(grd)
}
Try the loa package in your browser
Any scripts or data that you put into this service are public.
loa documentation built on Oct. 20, 2023, 5:09 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions triABCSquareGrid triXY2ABC triABC2XY.old triABC2XY triLimsReset panel.trianglePlot trianglePlot
Documented in panel.trianglePlot triABC2XY triABCSquareGrid trianglePlot triLimsReset triXY2ABC
#in development code
#[TBC - NUMBER] functions
#issue with trianglePlot
#axis misalignment in...
#trianglePlot(~Petal.Width+Sepal.Length+Sepal.Width, groups=iris$Species, data=iris)
#check trianglePlot
#is temp around the right way
# trianglePlot(ozone~wind*6+radiation+temperature*2, data=environmental)
#trianglePlot
#panel.trianglePlot
#panel.triangleByGroupPolygon
#panel.triangleKernelDensity
#panel.triangleSurfaceSmooth
#panel.trianglePlotFrame
#panel.trianglePlotGrid
#panel.trianglePlotAxes
#triLimsReset
#triABC2XY
#triXY2ABC
#triABCSquareGrid
#others now
#removed
###############################
#new trianglePlot
###############################
#this uses panelPal
#allows conditioning like in standard lattice
trianglePlot <- function(x, data = NULL, ..., ref.cols = TRUE){
#trianglePlot ver 0.2
#panelPal update
extra.args <- list(...)
if (is.logical(ref.cols))
ref.cols <- if (all(ref.cols))
c("darkgreen", "darkred", "darkblue")
else "black"
ref.cols <- rep(ref.cols, length.out=3)
extra.args <- listUpdate(list(x=x, data=data, formula.type="z~a0+b0+c0|cond",
coord.conversion=triABC2XY, panel=panel.trianglePlot, ref.cols=ref.cols),
extra.args)
do.call(loaPlot, extra.args)
}
##############################
#new panel.trianglePlot
##############################
#uses local.scales methods to handle axes
#local.scales.panel = panel.trianglePlotFrame
#data.panel = panel.loaPlot
#think about getting and adding to default settings in default data.panel?
#this would turn off key of key not set in data.panel?
panel.trianglePlot <-
function(x = NULL, y = NULL, a0 = NULL, b0 = NULL, c0 = NULL, ...,
loa.settings = FALSE, plot = TRUE, process = TRUE){
################
#this is based on panel.polarPlot
################
if(loa.settings)
return(list(group.args= c("col"),
zcase.args= c("pch"),
common.args = c("alim", "blim", "clim", "grid", "axes", "ticks", "annotation", "ref.cols"),
default.settings = list(local.scales = TRUE, local.scales.panel = panel.trianglePlotFrame,
data.panel = panel.loaPlot, grid = TRUE, axes = TRUE,
allowed.scales =c("a0", "b0", "c0"), disallowed.scales = c("x", "y"),
aspect = "loa.iso", reset.xylims = triLimsReset,
load.lists = c("grid", "axes", "ticks", "annotation"),
key.fun = "draw.loaPlotZKey")))
if(process){
###################
#to think about
###################
#make if missing
#x, y, a0, b0, c0,
#see below re polarplot code
if(!plot) return(list(x = x, y = y, a0=a0, b0=b0, c0=c0))
}
##
#######################
## the if missing would
## be like in polarPlot
#######################
##
## r <- x
## theta <- y
## x <- r * sin(pi * theta/180)
## y <- r * cos(pi * theta/180)
## if(!plot) return(list(x = x, y = y, r = r, theta = theta))
## }
if(plot){
extra.args <- listUpdate(list(...),
list(x = x, y = y, a0 = a0, b0=b0, c0=c0,
plot = plot, process = process))
###################
#might want to allow user to set this
#might want to be able to turn this off
#so not local.scales.panels
###################
###################
#might want to tidy
#the do.call
#data.panel does not
#need to be sent to
#data.panel...
###################
if ("groups" %in% names(extra.args) || "zcases" %in%
names(extra.args))
do.call(groupsAndZcasesPanelHandler, listUpdate(extra.args,
list(panel = extra.args$data.panel, plot = plot,
process = process), ignore = "grid"))
else do.call(extra.args$data.panel, listUpdate(extra.args,
list(), ignore = "grid"))
if (extra.args$local.scales)
if (is.function(extra.args$local.scales.panel)) {
do.call(extra.args$local.scales.panel, extra.args)
extra.args$grid <- NULL
}
}
}
#######################################################
#panel.triangleByGroupPolygon
#######################################################
panel.triangleByGroupPolygon <- function (x = NULL, y = NULL, a0 = NULL, b0 = NULL, c0 = NULL,
..., loa.settings = FALSE, plot = TRUE, process = TRUE)
{
#this is a temp solution
#it is very messy
#need to look at the alpha handling in plot section...
#also need to think about making a panel.loaPolygon which
# could fix a lot of this and give me more control of the
# polygons
if (loa.settings)
return(list(group.args = c("col"), zcase.args = c("pch"),
common.args = c("alim", "blim", "clim", "grid", "axes",
"ticks", "annotation", "ref.cols"), default.settings = list(local.scales = TRUE,
local.scales.panel = panel.trianglePlotFrame,
data.panel = panel.loaPlot, grid = TRUE, axes = TRUE,
allowed.scales = c("a0", "b0", "c0"), disallowed.scales = c("x",
"y"), aspect = "loa.iso", reset.xylims = triLimsReset,
load.lists = c("grid", "axes", "ticks", "annotation"),
key.fun = "draw.groupPlotKey")))
if (process) {
if (!plot)
return(list(x = x, y = y, a0 = a0, b0 = b0, c0 = c0))
}
if (plot) {
extra.args <- listUpdate(list(...), list(x = x, y = y,
a0 = a0, b0 = b0, c0 = c0, plot = plot, process = process))
if ("groups" %in% names(extra.args) || "zcases" %in%
names(extra.args))
do.call(groupsAndZcasesPanelHandler, listUpdate(extra.args,
list(panel = panel.polygon, plot = plot,
process = process), ignore = c("grid", "alpha", "alpha.regions")))
else {
#group/zcase handler assigns col
#but if no groups need to make sure it is set here
extra.args$col <- do.call(colHandler, extra.args)
do.call(panel.polygon, listUpdate(extra.args,
list(), ignore = c("grid", "alpha", "alpha.regions")))
}
if (extra.args$local.scales)
if (is.function(extra.args$local.scales.panel)) {
do.call(extra.args$local.scales.panel, extra.args)
extra.args$grid <- NULL
}
}
}
########################################################
#panel.triangleKernelDensity
########################################################
panel.triangleKernelDensity <- function (x = NULL, y = NULL, a0 = NULL, b0 = NULL, c0 = NULL,
..., loa.settings = FALSE, plot = TRUE, process = TRUE)
{
if (loa.settings)
return(list(group.args = c("col"), zcase.args = c("pch"),
common.args = c("alim", "blim", "clim", "grid", "axes",
"ticks", "annotation", "ref.cols"), default.settings = list(local.scales = TRUE,
local.scales.panel = panel.trianglePlotFrame,
data.panel = panel.loaLevelPlot, grid = TRUE,
axes = TRUE, allowed.scales = c("a0", "b0", "c0"),
disallowed.scales = c("x", "y"), aspect = "loa.iso",
reset.xylims = triLimsReset, load.lists = c("grid",
"axes", "ticks", "annotation"), n = 200, key.fun = "draw.loaColorKey",
key.raster = TRUE, isolate.col.regions = TRUE)))
if (process) {
if (!plot) {
extra.args <- list(...)
temp <- as.list(model.frame(data.frame(x = x, y = y,
a0 = a0, b0 = b0, c0 = c0)))
#tidy this bit
plotlist <- listUpdate(extra.args,
list(x = temp$x, y = temp$y, plot = FALSE, process = TRUE))
if(all(c("alim", "blim", "clim") %in% names(extra.args))){
#reset xlim and ylim for this
abc <- with(extra.args,
triABC2XY(a=c(alim[1], alim[2], alim[1]),
b=c(blim[1], blim[1], blim[2]),
c=c(clim[2], clim[1], clim[1])))
plotlist$xlim <- abc$x[c(1,3)]
plotlist$ylim <- abc$y[c(1,2)]
}
#but need to keep what is temp simple
#no xlim, ylim, etc.
#just x and y and z here
temp <- do.call(panel.kernelDensity, plotlist)
#make a b and c for new x y...
abc <- do.call(triXY2ABC, temp)
temp$a0 <- abc$a
temp$b0 <- abc$b
temp$c0 <- abc$c
#other option could be to strip out all not xyzabc here?
temp <- as.data.frame(temp)
#restrtict to range of triangle plot
temp <- if("alim" %in% names(extra.args))
temp[temp$a0 >= extra.args$alim[1] & temp$a0 <= extra.args$alim[2], ] else
temp[temp$a0 >= 0 & temp$a0 <= 1, ]
temp <- if("blim" %in% names(extra.args))
temp[temp$b0 >= extra.args$blim[1] & temp$b0 <= extra.args$blim[2], ] else
temp[temp$b0 >= 0 & temp$b0 <= 1, ]
temp <- if("clim" %in% names(extra.args))
temp[temp$c0 >= extra.args$clim[1] & temp$c0 <= extra.args$clim[2], ] else
temp[temp$c0 >= 0 & temp$c0 <= 1, ]
return(temp)
}
}
if (plot) {
extra.args <- listUpdate(list(...), list(x = x, y = y,
a0 = a0, b0 = b0, c0 = c0, plot = plot, process = process))
if ("groups" %in% names(extra.args) || "zcases" %in%
names(extra.args))
do.call(groupsAndZcasesPanelHandler, listUpdate(extra.args,
list(panel = extra.args$data.panel, plot = plot,
process = process), ignore = "grid"))
else do.call(extra.args$data.panel, listUpdate(extra.args,
list(), ignore = "grid"))
if (extra.args$local.scales)
if (is.function(extra.args$local.scales.panel)) {
do.call(extra.args$local.scales.panel, extra.args)
extra.args$grid <- NULL
}
}
}
#################################################
#panel.triangleSurfaceSmooth
#################################################
panel.triangleSurfaceSmooth <- function (x = NULL, y = NULL, z = NULL, a0 = NULL, b0 = NULL,
c0 = NULL, ..., loa.settings = FALSE, plot = TRUE, process = TRUE)
{
if (loa.settings)
return(list(group.args = c("col"), zcase.args = c("pch"),
common.args = c("alim", "blim", "clim", "grid", "axes",
"ticks", "annotation", "ref.cols"), default.settings = list(local.scales = TRUE,
local.scales.panel = panel.trianglePlotFrame,
data.panel = panel.loaLevelPlot, grid = TRUE,
axes = TRUE, allowed.scales = c("a0", "b0", "c0"),
disallowed.scales = c("x", "y"), aspect = "loa.iso",
reset.xylims = triLimsReset, load.lists = c("grid",
"axes", "ticks", "annotation"), n = 200, key.fun = "draw.loaColorKey",
key.raster = TRUE, isolate.col.regions = TRUE)))
if (process) {
if (!plot) {
#like panel.triangleKernelDensity
extra.args <- list(...)
temp <- as.list(model.frame(data.frame(x = x, y = y,
z = z, a0 = a0, b0 = b0, c0 = c0)))
plotlist <- listUpdate(extra.args,
list(x = temp$x, y = temp$y, z = temp$z, plot = FALSE, process = TRUE))
if(all(c("alim", "blim", "clim") %in% names(extra.args))){
#reset xlim and ylim for this
abc <- with(extra.args,
triABC2XY(a=c(alim[1], alim[2], alim[1]),
b=c(blim[1], blim[1], blim[2]),
c=c(clim[2], clim[1], clim[1])))
plotlist$xlim <- abc$x[c(1,3)]
plotlist$ylim <- abc$y[c(1,2)]
}
temp <- do.call(panel.surfaceSmooth, plotlist)
abc <- do.call(triXY2ABC, temp)
temp$a0 <- abc$a
temp$b0 <- abc$b
temp$c0 <- abc$c
temp <- as.data.frame(temp)
temp <- if("alim" %in% names(extra.args))
temp[temp$a0 >= extra.args$alim[1] & temp$a0 <= extra.args$alim[2], ] else
temp[temp$a0 >= 0 & temp$a0 <= 1, ]
temp <- if("blim" %in% names(extra.args))
temp[temp$b0 >= extra.args$blim[1] & temp$b0 <= extra.args$blim[2], ] else
temp[temp$b0 >= 0 & temp$b0 <= 1, ]
temp <- if("clim" %in% names(extra.args))
temp[temp$c0 >= extra.args$clim[1] & temp$c0 <= extra.args$clim[2], ] else
temp[temp$c0 >= 0 & temp$c0 <= 1, ]
return(temp)
}
}
if (plot) {
extra.args <- listUpdate(list(...), list(x = x, y = y,
z = z, a0 = a0, b0 = b0, c0 = c0, plot = plot, process = process))
if ("groups" %in% names(extra.args) || "zcases" %in%
names(extra.args))
do.call(groupsAndZcasesPanelHandler, listUpdate(extra.args,
list(panel = extra.args$data.panel, plot = plot,
process = process), ignore = "grid"))
else do.call(extra.args$data.panel, listUpdate(extra.args,
list(), ignore = "grid"))
if (extra.args$local.scales)
if (is.function(extra.args$local.scales.panel)) {
do.call(extra.args$local.scales.panel, extra.args)
extra.args$grid <- NULL
}
}
}
##############################
#panel.trianglePlotFrame
##############################
panel.trianglePlotFrame <-
function (..., grid = NULL, axes = NULL)
{
extra.args <- list(...)
#could tidy this?
if (isGood4LOA(grid)){
if(is.list(grid) && is.function(grid$panel))
do.call(grid$panel, listUpdate(extra.args, list(grid=grid), ignore="panel")) else
do.call(panel.trianglePlotGrid, listUpdate(extra.args, list(grid=grid), ignore="panel"))
}
if (isGood4LOA(axes)){
if(is.list(axes) && is.function(axes$panel))
do.call(axes$panel, listUpdate(extra.args, list(axes=axes), ignore="panel")) else
do.call(panel.trianglePlotAxes, listUpdate(extra.args, list(axes=axes), ignore="panel"))
}
}
############################
#panel.trianglePlotGrid
############################
panel.trianglePlotGrid <-
function (alim = NULL, blim = NULL, clim = NULL,
..., grid = TRUE, panel.scales = NULL)
{
extra.args <- list(...)
if (!is.list(panel.scales))
panel.scales <- list()
if (!is.list(grid))
grid <- list()
panel.scales <- listUpdate(list(draw = TRUE, arrows = FALSE,
lty=3,
tick.number = 5, abbreviate = FALSE, minlength = 4, tck = 1,
col= "lightgrey", cex = 0.8), panel.scales)
grid <- do.call(listLoad, listUpdate(grid, list(load="a0")))
grid <- do.call(listLoad, listUpdate(grid, list(load="b0")))
grid <- do.call(listLoad, listUpdate(grid, list(load="c0")))
temp <- list(a0=list(col=extra.args$ref.cols[1]),
b0=list(col=extra.args$ref.cols[2]),
c0=list(col=extra.args$ref.cols[3]))
if(is.null(grid$col)) grid <- listUpdate(temp, grid)
grid.pars <- getPlotArgs("axis.line", local.resets = panel.scales,
user.resets = grid, elements = c("a0", "b0", "c0"),
is.scale=TRUE, defaults.only = FALSE)
at.loc <- function(par, lim){
temp <- listUpdate(list(tick.number=5), par, use=c("at", "tick.number"))
temp <- if (!is.null(temp$at)) temp$at else
pretty(lim, temp$tick.number)
#remove any out of range
#if range too big
temp[temp >= min(lim, na.rm=T) & temp <= max(lim, na.rm=T)]
}
#a axis
a.at <- at.loc(grid.pars$a, alim)
temp <- function(x) {
a1 <- triABC2XY(c(x, x), c(blim[1], blim[2] - (x - alim[1])),
c(clim[2] - (x - alim[1]), clim[1]))
if (isGood4LOA(grid.pars$a)){
grid.pars$a$x <- a1$x
grid.pars$a$y <- a1$y
do.call(llines, grid.pars$a)
}
}
for (i in a.at) temp(i)
#b axis
b.at <- at.loc(grid.pars$b, blim)
temp <- function(x) {
b1 <- triABC2XY(c(alim[1], alim[2] - (x - blim[1])),
c(x, x), c(clim[2] - (x - blim[1]), clim[1]))
if (isGood4LOA(grid.pars$b)){
grid.pars$b$x <- b1$x
grid.pars$b$y <- b1$y
do.call(llines, grid.pars$b)
}
}
for (i in b.at) temp(i)
#c axis
c.at <- at.loc(grid.pars$c, clim)
temp <- function(x) {
c1 <- triABC2XY(c(alim[1], alim[2] - (x - clim[1])),
c(blim[2] - (x - clim[1]), blim[1]), c(x, x))
if (isGood4LOA(grid.pars$c)){
grid.pars$c$x <- c1$x
grid.pars$c$y <- c1$y
do.call(llines, grid.pars$c)
}
}
for (i in c.at) temp(i)
}
############################
#panel.trianglePlotAxes
############################
panel.trianglePlotAxes <-
function (alim = NULL, blim = NULL, clim = NULL, ...,
axes = TRUE, ticks=TRUE, annotation=TRUE,
panel.scales = NULL)
{
#reposition a and b labs so parallel to axes
#look and management of font size in local labels handler
#
extra.args <- list(...)
alab <- if(is.null(extra.args$alab)) extra.args$a0lab else extra.args$alab
blab <- if(is.null(extra.args$blab)) extra.args$b0lab else extra.args$blab
clab <- if(is.null(extra.args$clab)) extra.args$c0lab else extra.args$clab
if (!is.list(panel.scales))
panel.scales <- list()
if (!is.list(axes))
axes <- list()
# if (!is.list(ticks))
# ticks <- list()
# if (!is.list(annotation))
# annotation <- list()
temp <- prod(dim(trellis.currentLayout()),na.rm=T)
text.cex <- 1
if(temp>1) text.cex <- 0.8
if(temp>3) text.cex <- 0.7
if(temp>3) text.cex <- 0.6
if(temp>9) text.cex <- 0.5
temp <- list(a0=list(col=extra.args$ref.cols[1]),
b0=list(col=extra.args$ref.cols[2]),
c0=list(col=extra.args$ref.cols[3]))
axes <- do.call(listLoad, listUpdate(axes, list(load="a0")))
axes <- do.call(listLoad, listUpdate(axes, list(load="b0")))
axes <- do.call(listLoad, listUpdate(axes, list(load="c0")))
if(isGood4LOA(ticks)){
if(!is.list(ticks)) ticks <- list()
ticks <- do.call(listLoad, listUpdate(ticks, list(load="a0")))
ticks <- do.call(listLoad, listUpdate(ticks, list(load="b0")))
ticks <- do.call(listLoad, listUpdate(ticks, list(load="c0")))
if(is.null(ticks$col)) ticks <- listUpdate(temp, ticks)
} else ticks <- list(col=NA)
if(isGood4LOA(annotation)){
if(!is.list(annotation)) annotation <- list()
annotation <- do.call(listLoad, listUpdate(annotation, list(load="a0")))
annotation <- do.call(listLoad, listUpdate(annotation, list(load="b0")))
annotation <- do.call(listLoad, listUpdate(annotation, list(load="c0")))
if(is.null(annotation$cex)) annotation$cex <- (text.cex*0.8)
if(is.null(annotation$col)) annotation <- listUpdate(temp, annotation)
} else annotation <- list(col=NA)
# panel.scales <- listUpdate(list(draw = TRUE, arrows = FALSE,
# tick.number = 5, abbreviate = FALSE, minlength = 4, tck = 1,
# col = "red", col.line = 1, cex = 0.8), panel.scales)
axis.loc <- function(n, lim) (n * (max(lim, na.rm = TRUE) -
min(lim, na.rm = TRUE))) + min(lim, na.rm = TRUE)
at.loc <- function(par, axes, ticks, lim){
temp <- listUpdate(par, axes, use=c("at", "tick.number"))
temp <- listUpdate(temp, ticks, use=c("at", "tick.number"))
if(!is.null(temp$at)) temp$at else pretty(lim, temp$tick.number)
}
axes.pars <- getPlotArgs(default.as = "axis.line", source = panel.scales,
elements = c("a0", "b0", "c0"), is.scales = TRUE, user.resets = axes)
tick.pars <- getPlotArgs(default.as = "axis.line", source = panel.scales,
elements = c("a0", "b0", "c0"), is.scales = TRUE, user.resets = ticks)
ann.pars <- getPlotArgs(default.as = "axis.text", source = panel.scales,
elements = c("a0", "b0", "c0"), is.scales = TRUE, user.resets = annotation)
#this fixes the current issue with getPlotArgs
ann.pars$a0 <- listUpdate(annotation, ann.pars$a0, ignore.a=c("a0", "b0", "c0"))
ann.pars$b0 <- listUpdate(annotation, ann.pars$b0, ignore.a=c("a0", "b0", "c0"))
ann.pars$c0 <- listUpdate(annotation, ann.pars$c0, ignore.a=c("a0", "b0", "c0"))
#need to fix this
###currently changes to ticks but not others
###this gives us full axes control but
###using n0 axis name not n
###print(tick.pars)
panel.scales$a <- listUpdate(list(at = at.loc(list(tick.number=5), axes.pars$a, tick.pars$a, alim)),
panel.scales$a)
# tick.pars$a$isGood4LOA <- TRUE
# ann.pars$a$isGood4LOA <- TRUE
temp <- triABC2XY(c(axis.loc(0.5, alim), axis.loc(0.5, alim),
axis.loc(0, alim), axis.loc(1, alim)), c(axis.loc(0.1,
blim), axis.loc(0, blim), axis.loc(0, blim), axis.loc(0,
blim)), c(axis.loc(0.4, clim), axis.loc(0.5, clim), axis.loc(1,
clim), axis.loc(0, clim)))
panel.localScale(panel.scale = panel.scales$a, x.loc = temp$x[3:4],
y.loc = temp$y[3:4], lim = alim, x.offset = temp$x[2] -
temp$x[1], y.offset = temp$y[2] - temp$y[1], axis = axes.pars$a0,
ticks=tick.pars$a0, annotation=ann.pars$a0)
# ltext(x = temp$x[1] - (3 * (temp$x[2] - temp$x[1])) - (3 *
# (temp$x[1] - temp$x[3])), y = temp$y[1] + (2 * (y.offset = temp$y[2] -
# temp$y[1])), alab, adj = c(1, 0.5), srt=60)
ltext(x = temp$x[1] + (4 * (temp$x[2] - temp$x[1])), y = temp$y[1] +
(3 * (y.offset = temp$y[2] - temp$y[1])), alab, adj = c(0.5,
0.5), srt=60, cex = text.cex)
panel.scales$b <- listUpdate(list(at = at.loc(list(tick.number=5), axes.pars$b, tick.pars$b, blim)),
panel.scales$b)
# tick.pars$b$isGood4LOA <- TRUE
# ann.pars$b$isGood4LOA <- TRUE
temp <- triABC2XY(c(axis.loc(0.4, alim), axis.loc(0.5, alim),
axis.loc(1, alim), axis.loc(0, alim)), c(axis.loc(0.5,
blim), axis.loc(0.5, blim), axis.loc(0, blim), axis.loc(1,
blim)), c(axis.loc(0.1, clim), axis.loc(0, clim), axis.loc(0,
clim), axis.loc(0, clim)))
panel.localScale(panel.scale = panel.scales$b, x.loc = temp$x[3:4],
y.loc = temp$y[3:4], lim = blim, x.offset = temp$x[2] -
temp$x[1], y.offset = temp$y[2] - temp$y[1], axis = axes.pars$b0,
ticks = tick.pars$b0, annotation = ann.pars$b0)
ltext(x = temp$x[1] + (4 * (temp$x[2] - temp$x[1])), y = temp$y[1] +
(3 * (y.offset = temp$y[2] - temp$y[1])), blab, adj = c(0.5,
0.5), srt=300, cex = text.cex)
panel.scales$c <- listUpdate(list(at = at.loc(list(tick.number=5), axes.pars$c, tick.pars$c, clim)),
panel.scales$c)
# tick.pars$c$isGood4LOA <- TRUE
# ann.pars$c$isGood4LOA <- TRUE
temp <- triABC2XY(c(axis.loc(0.1, alim), axis.loc(0, alim),
axis.loc(0, alim), axis.loc(0, alim)), c(axis.loc(0.4,
blim), axis.loc(0.5, blim), axis.loc(1, blim), axis.loc(0,
blim)), c(axis.loc(0.5, clim), axis.loc(0.5, clim), axis.loc(0,
clim), axis.loc(1, clim)))
panel.localScale(panel.scale = panel.scales$c, x.loc = temp$x[3:4],
y.loc = temp$y[3:4], lim = clim, x.offset = temp$x[2] -
temp$x[1], y.offset = temp$y[2] - temp$y[1], axis = axes.pars$c0,
ticks = tick.pars$c0, annotation = ann.pars$c0)
ltext(x = temp$x[2], y = temp$y[1] + (3 * (y.offset = temp$y[2] -
temp$y[1])), clab, adj = c(0.5, 0.5), cex=text.cex)
}
#############################
#############################
##data handlers
#############################
#############################
###############################
#triLimsReset
###############################
triLimsReset <-
function(ans){
#what is not a, b, clim values
#does function in preprocess make them?
#messy
temp <- ans$panel.args.common
temp <- triABC2XY(a = c(temp$alim[1], temp$alim[1], temp$alim[2]),
b = c(temp$blim[1], temp$blim[2], temp$blim[1]), c = c(temp$clim[2],
temp$clim[1], temp$clim[1]), verbose = FALSE)
xlim <- range(temp$x, na.rm = TRUE)
ylim <- range(temp$y, na.rm = TRUE)
ans$panel.args.common$xlim <- xlim
ans$x.limits <- xlim
ans$panel.args.common$ylim <- ylim
ans$y.limits <- ylim
temp <- function(lim, q1, q2) {
if (diff(lim) == 0)
lim + q1
else lim + c(-(diff(lim)/q2[1]), (diff(lim)/q2[2]))
}
#messy
extra.args <- ans$panel.args.common
alab <- if(is.null(extra.args$alab)) extra.args$a0lab else extra.args$alab
blab <- if(is.null(extra.args$blab)) extra.args$b0lab else extra.args$blab
clab <- if(is.null(extra.args$clab)) extra.args$c0lab else extra.args$clab
if (is.null(clab)) {
extra.args$xlim <- temp(extra.args$xlim, c(-0.5, 0.5),
c(5, 5))
extra.args$ylim <- temp(extra.args$ylim, c(-0.5, 0.5),
c(5, 5))
}
else if (is.character(clab) && clab == "") {
extra.args$xlim <- temp(extra.args$xlim, c(-0.5, 0.5),
c(5, 5))
extra.args$ylim <- temp(extra.args$ylim, c(-0.5, 0.5),
c(5, 5))
}
else {
extra.args$xlim <- temp(extra.args$xlim, c(-0.5, 0.5),
c(5, 5))
extra.args$ylim <- temp(extra.args$ylim, c(-0.3, 0.5),
c(3, 5))
}
ans$panel.args.common <- extra.args
ans$x.limits <- ans$panel.args.common$xlim
ans$y.limits <- ans$panel.args.common$ylim
ans
}
##############################
##############################
##triABC2XY
##############################
##############################
triABC2XY <- function(a, b=NULL, c=NULL, ..., force.abc=TRUE,
if.na="remove.row", if.neg="remove.row", verbose=FALSE){
#############
#setup
#############
#extra.args
extra.args <- list(...)
#############
#new
#############
#if a,b,c not there
#use a0, b0, and c0 if there
if(missing(a) && "a0" %in% names(extra.args)) a <- extra.args$a0
if(is.null(b) && "b0" %in% names(extra.args)) b <- extra.args$b0
if(is.null(c) && "c0" %in% names(extra.args)) c <- extra.args$c0
#############
#
#make a,b,c a data.frame
################
#could standardise this next bit and front end of triXY2ABC
#and make common function dataHandler
#could also put the logs in there
################
data.abc <- if(is.data.frame(a)) a else
if(is.list(a)) as.data.frame(a) else
if(is.vector(a)) data.frame(a=a) else
stop("unable to handle supplied data", call. = FALSE)
###################
#possible issue if
#a shorter than b,c
###################
if(is.vector(b))
data.abc$b <- if(length(b) < nrow(data.abc))
rep(b, ceiling(nrow(data.abc)/length(b)))[1:nrow(data.abc)] else
b[1:nrow(data.abc)]
if(is.vector(c))
data.abc$c <- if(length(c) < nrow(data.abc))
rep(c, ceiling(nrow(data.abc)/length(c)))[1:nrow(data.abc)] else
c[1:nrow(data.abc)]
#check dim
if(ncol(data.abc) < 3)
stop("insufficient data for 'abc' assignment", call. = FALSE)
#force.abc/rescale
temp <- data.abc[,1:3]
if(force.abc){
if("a" %in% names(data.abc)) temp[,1] <- data.abc$a
if("b" %in% names(data.abc)) temp[,2] <- data.abc$b
if("c" %in% names(data.abc)) temp[,3] <- data.abc$c
}
data.abc <- temp
abc.status <- rep(0, nrow(data.abc)) #abc.status
###########
#if.neg and if.na
###########
##############
#need keep.as.is catcher
##############
na.log <- apply(data.abc, 1, function(x) any(is.na(x))) #na
neg.log <- apply(data.abc, 1, function(x) any(!is.na(x) & x<0)) #negs
if(any(na.log)) {
if(if.na == "remove.row")
data.abc[na.log, 1:3] <- c(NA,NA,NA)
if(if.na == "make.zero")
data.abc[is.na(data.abc)] <- 0
}
if(any(neg.log)) {
if(if.neg == "remove.row")
data.abc[neg.log, 1:3] <- c(NA,NA,NA)
if(if.neg == "make.zero")
data.abc[data.abc<0] <- 0
if(if.neg == "rescale.col")
if(nrow(data.abc)==1)
data.abc[data.abc<0] <- 0 else
data.abc <- as.data.frame(apply(data.abc, 2, function(x)
if(min(x, na.rm=TRUE)<0) x-min(x, na.rm=TRUE) else x))
}
#############
#below needs documenting in help
#############
#abc 2 prop(abc)
#function used again later
prop.abc <- function(d){
temp <- d[,1] + d[,2] + d[,3]
d/temp
}
data.abc <- prop.abc(data.abc)
temp <- apply(data.abc, 2, function(x)
diff(range(x, na.rm=TRUE)))
abc.bord <- if(all(is.na(temp))) 0.05 else
max(temp, na.rm=TRUE) * 0.1
if(abc.bord <= 0) abc.bord <- 0.05
#abc.bord is plot border
lims <- data.frame(a=c(0,1),b=c(0,1),c=c(0,1))
#shrink c
temp <- seq(lims[1,3], lims[2,3], length.out=20)
#temp <- pretty(c(lims[1,3], lims[2,3]), 10)
temp <- temp[temp < min(data.abc[,3]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,3]
lims[1,3] <- lims[1,3]+temp
lims[2,1] <- lims[2,1]-temp
lims[2,2] <- lims[2,2]-temp
#shrink b
temp <- seq(lims[1,2], lims[2,2], length.out=20)
#temp <- pretty(c(lims[1,2], lims[2,2]), 10)
temp <- temp[temp<min(data.abc[,2]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,2]
lims[1,2] <- lims[1,2]+temp
lims[2,1] <- lims[2,1]-temp
lims[2,3] <- lims[2,3]-temp
#shrink a
temp <- seq(lims[1,1], lims[2,1], length.out=20)
#temp <- pretty(c(lims[1,1], lims[2,1]), 10)
temp <- temp[temp<min(data.abc[,1]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,1]
lims[1,1] <- lims[1,1]+temp
lims[2,2] <- lims[2,2]-temp
lims[2,3] <- lims[2,3]-temp
#shrink c
temp <- seq(lims[1,3], lims[2,3], length.out=20)
#temp <- pretty(c(lims[1,3], lims[2,3]), 10)
temp <- temp[temp < min(data.abc[,3]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,3]
lims[1,3] <- lims[1,3]+temp
lims[2,1] <- lims[2,1]-temp
lims[2,2] <- lims[2,2]-temp
#shrink b
temp <- seq(lims[1,2], lims[2,2], length.out=20)
#temp <- pretty(c(lims[1,2], lims[2,2]), 10)
temp <- temp[temp<min(data.abc[,2]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,2]
lims[1,2] <- lims[1,2]+temp
lims[2,1] <- lims[2,1]-temp
lims[2,3] <- lims[2,3]-temp
#shrink a
temp <- seq(lims[1,1], lims[2,1], length.out=20)
#temp <- pretty(c(lims[1,1], lims[2,1]), 10)
temp <- temp[temp<min(data.abc[,1]-abc.bord, na.rm=TRUE)]
temp <- if(length(temp) < 1) 0 else
max(c(temp, 0), na.rm=TRUE)
temp <- temp - lims[1,1]
lims[1,1] <- lims[1,1]+temp
lims[2,2] <- lims[2,2]-temp
lims[2,3] <- lims[2,3]-temp
ans <- list(x = data.abc[,2]+(0.5*data.abc[,1]),
y = ((data.abc[,1]*0.866)*1.1)/1, #confirm 1.1
alim = lims[,1], blim = lims[,2], clim = lims[,3])
if(!verbose) return(ans)
#full return
#may want to rethink structure
#re passing a,b,c to xyplot.formula...
#check for out of range values
##compare with lims
oor.log <- rep(FALSE, nrow(data.abc))
oor.log <- ifelse(data.abc[,1] < min(lims[,1], na.rm=TRUE) |
data.abc[,1] > max(lims[,1], na.rm=TRUE), TRUE, oor.log)
oor.log <- ifelse(data.abc[,2] < min(lims[,2], na.rm=TRUE) |
data.abc[,2] > max(lims[,2], na.rm=TRUE), TRUE, oor.log)
oor.log <- ifelse(data.abc[,3] < min(lims[,3], na.rm=TRUE) |
data.abc[,3] > max(lims[,3], na.rm=TRUE), TRUE, oor.log)
#catch na's
oor.log[is.na(oor.log)]<- FALSE
listUpdate(ans, list(a=data.abc[,1], b=data.abc[,2], c=data.abc[,3],
report = list(nas=na.log, negs=neg.log, oor=oor.log)))
}
triABC2XY.old <- function(a, b=NULL, c=NULL, ..., force.abc=TRUE,
if.na="remove.row", if.neg="remove.row", verbose=FALSE){
#############
#setup
#############
#extra.args
extra.args <- list(...)
#############
#new
#############
#if a,b,c not there
#use a0, b0, and c0 if there
if(missing(a) && "a0" %in% names(extra.args)) a <- extra.args$a0
if(is.null(b) && "b0" %in% names(extra.args)) b <- extra.args$b0
if(is.null(c) && "c0" %in% names(extra.args)) c <- extra.args$c0
#############
#
#make a,b,c a data.frame
################
#could standardise this next bit and front end of triXY2ABC
#and make common function dataHandler
#could also put the logs in there
################
data.abc <- if(is.data.frame(a)) a else
if(is.list(a)) as.data.frame(a) else
if(is.vector(a)) data.frame(a=a) else
stop("unable to handle supplied data", call. = FALSE)
###################
#possible issue if
#a shorter than b,c
###################
if(is.vector(b))
data.abc$b <- if(length(b) < nrow(data.abc))
rep(b, ceiling(nrow(data.abc)/length(b)))[1:nrow(data.abc)] else
b[1:nrow(data.abc)]
if(is.vector(c))
data.abc$c <- if(length(c) < nrow(data.abc))
rep(c, ceiling(nrow(data.abc)/length(c)))[1:nrow(data.abc)] else
c[1:nrow(data.abc)]
#check dim
if(ncol(data.abc) < 3)
stop("insufficient data for 'abc' assignment", call. = FALSE)
#force.abc/rescale
temp <- data.abc[,1:3]
if(force.abc){
if("a" %in% names(data.abc)) temp[,1] <- data.abc$a
if("b" %in% names(data.abc)) temp[,2] <- data.abc$b
if("c" %in% names(data.abc)) temp[,3] <- data.abc$c
}
data.abc <- temp
abc.status <- rep(0, nrow(data.abc)) #abc.status
###########
#if.neg and if.na
###########
##############
#need keep.as.is catcher
##############
na.log <- apply(data.abc, 1, function(x) any(is.na(x))) #na
neg.log <- apply(data.abc, 1, function(x) any(!is.na(x) & x<0)) #negs
if(any(na.log)) {
if(if.na == "remove.row")
data.abc[na.log, 1:3] <- c(NA,NA,NA)
if(if.na == "make.zero")
data.abc[is.na(data.abc)] <- 0
}
if(any(neg.log)) {
if(if.neg == "remove.row")
data.abc[neg.log, 1:3] <- c(NA,NA,NA)
if(if.neg == "make.zero")
data.abc[data.abc<0] <- 0
if(if.neg == "rescale.col")
if(nrow(data.abc)==1)
data.abc[data.abc<0] <- 0 else
data.abc <- as.data.frame(apply(data.abc, 2, function(x)
if(min(x, na.rm=TRUE)<0) x-min(x, na.rm=TRUE) else x))
}
#############
#below needs documenting in help
#############
#abc 2 prop(abc)
#function used again later
prop.abc <- function(d){
temp <- d[,1] + d[,2] + d[,3]
d/temp
}
data.abc <- prop.abc(data.abc)
################################
################################
##############
#lim forcings
##############
##################
#following based on ade4/Daniel Chessel method
#################
##selection of sensible lim range
#could move this to separate/as data handlers
#
#lim forcings
if(is.null(extra.args$lims)){
lims <- apply(data.abc, 2, range, na.rm = TRUE, finite = TRUE)
lims[1,] <- (floor(lims[1,]/0.1))/10
lims[2,] <- (floor(lims[2,]/0.1) + 1)/10
} else {
lims <- as.data.frame(matrix(rep(extra.args$lims[1:2], 3),
ncol = 3, nrow = 2))
}
if(!is.null(extra.args$alim))
lims[,1] <- extra.args$alim
if(!is.null(extra.args$blim))
lims[,2] <- extra.args$blim
if(!is.null(extra.args$clim))
lims[,3] <- extra.args$clim
if(!is.null(extra.args$abc.mins))
lims[1,] <- extra.args$abc.mins
if(!is.null(extra.args$abc.maxs))
lims[2,] <- extra.args$abc.maxs
#stop the bad
lims[1,][lims[1,] < 0] <- 0
lims[2,][lims[2,] > 1] <- 1
#lims range
#ade4 method
##############
#rethink this?
##############
lim.lite <-function(lims){
temp <- lims[2,] - lims[1,]
temp2 <- max(temp)
if (!all(temp == temp2)) {
for (j in 1:3) {
k <- temp2 - temp[j]
while (k > 0) {
if ((k > 0) & (lims[2,j] < 1)) {
lims[2,j] <- lims[2,j] + 0.1
k <- k - 1
}
if ((k > 0) & (lims[1,j] > 0)) {
lims[1,j] <- lims[1,j] - 0.1
k <- k - 1
}
}
}
}
cal <- matrix(0, 9, 3)
cal[1, 1] <- lims[1,1]
cal[1, 2] <- lims[1,2]
cal[1, 3] <- 1 - cal[1, 1] - cal[1, 2]
cal[2, 1] <- lims[1,1]
cal[2, 2] <- lims[2,2]
cal[2, 3] <- 1 - cal[2, 1] - cal[2, 2]
cal[3, 1] <- lims[2,1]
cal[3, 2] <- lims[1,2]
cal[3, 3] <- 1 - cal[3, 1] - cal[3, 2]
cal[4, 1] <- lims[1,1]
cal[4, 3] <- lims[1,3]
cal[4, 2] <- 1 - cal[4, 1] - cal[4, 3]
cal[5, 1] <- lims[1,1]
cal[5, 3] <- lims[2,3]
cal[5, 2] <- 1 - cal[5, 1] - cal[5, 3]
cal[6, 1] <- lims[2,1]
cal[6, 3] <- lims[1,3]
cal[6, 2] <- 1 - cal[6, 1] - cal[6, 3]
cal[7, 2] <- lims[1,2]
cal[7, 3] <- lims[1,3]
cal[7, 1] <- 1 - cal[7, 2] - cal[7, 3]
cal[8, 2] <- lims[1,2]
cal[8, 3] <- lims[2,3]
cal[8, 1] <- 1 - cal[8, 2] - cal[8, 3]
cal[9, 2] <- lims[2,2]
cal[9, 3] <- lims[1,3]
cal[9, 1] <- 1 - cal[9, 2] - cal[9, 3]
lims[1,] <- apply(cal, 2, min)
lims[1,] <- round(lims[1,], digits = 4)
lims[2,] <- apply(cal, 2, max)
lims[2,] <- round(lims[2,], digits = 4)
###################
#new bit
#bad lims
temp <- lims[2,] -lims[1,]
if(length(unique(temp))>1)
lims[2,] <- lims[1,] + max(temp, na.rm=TRUE)
#####################
#stop the bad
lims[1,][lims[1,] < 0] <- 0
lims[2,][lims[2,] > 1] <- 1
lims
}
lims <- lim.lite(lims)
#check if next bit needed
temp <- lims[2,] - lims[1,]
temp2 <- max(temp)
if (!all(temp == temp2))
lims <- lim.lite(lims)
if (!all(temp == temp2))
lims <- lim.lite(lims)
################################
################################
#check for out of range values
##compare with lims
oor.log <- rep(FALSE, nrow(data.abc))
oor.log <- ifelse(data.abc[,1] < min(lims[,1], na.rm=TRUE) |
data.abc[,1] > max(lims[,1], na.rm=TRUE), TRUE, oor.log)
oor.log <- ifelse(data.abc[,2] < min(lims[,2], na.rm=TRUE) |
data.abc[,2] > max(lims[,2], na.rm=TRUE), TRUE, oor.log)
oor.log <- ifelse(data.abc[,3] < min(lims[,3], na.rm=TRUE) |
data.abc[,3] > max(lims[,3], na.rm=TRUE), TRUE, oor.log)
#catch na's
oor.log[is.na(oor.log)]<- FALSE
data.abc[oor.log, 1:3] <- c(NA,NA,NA)
#################
##following based on Mu Zhu,
##Statistical Computing and Graphics 19,1, 2008
#################
#eta <- 0.08
#anchor <- diag(3)
#alpha1 <- c(1, -1, 0)/sqrt(2)
#alpha2 <- c(-0.5, -0.5, 1)/sqrt(1.5)
#vert.x <- anchor %*% alpha1
#vert.y <- anchor %*% alpha2
#x <- as.matrix(data.abc) * alpha1
#y <- as.matrix(data.abc) * alpha2
#ans <- list(x = x,
# y = y,
# alim = lims[,1], blim = lims[,2], clim = lims[,3])
##################
#following based on ade4/Daniel Chessel method
#################
##with this abc -> xy scaling is local so triangle size remains constant
##if this is adopted we could simplify panel... functions
##rescale axis
##rescale.axis <- function(n, lim)
## (n - lim[1])/(lim[2]-lim[1])
##temp <- data.abc
##temp[,1] <- rescale.axis(temp[,1], lims[,1])
##temp[,2] <- rescale.axis(temp[,2], lims[,2])
##temp[,3] <- rescale.axis(temp[,3], lims[,3])
##temp <- prop.abc(temp)
#basic return x,y a/b/clim
##ans <- list(x = (temp[,1] - temp[,3])/sqrt(2),
## y = (2 * temp[,2] - temp[,1] - temp[,3])/sqrt(6),
## alim = lims[,1], blim = lims[,2], clim = lims[,3])
##alternative method from Leic method?
##with this abc -> xy scaling fixed and triangle size changes
##with this panel... stay as is but triXY2ABC is greatly simplified
##also lim setting much less flexible
ans <- list(x = data.abc[,2]+(0.5*data.abc[,1]),
y = ((data.abc[,1]*0.867)*1.1)/1, #confirm 1.1
alim = lims[,1], blim = lims[,2], clim = lims[,3])
if(!verbose) return(ans)
#full return
#may want to rethink structure
#re passing a,b,c to xyplot.formula...
listUpdate(ans, list(a=data.abc[,1], b=data.abc[,2], c=data.abc[,3],
report = list(nas=na.log, negs=neg.log, oor=oor.log)))
}
##############################
##############################
##triXY2ABC
##############################
##############################
triXY2ABC <- function(x, y=NULL, ..., force.xy=TRUE, verbose=FALSE){
#############
#setup
#############
#make xy a data.frame
data.xy <- if(is.data.frame(x)) a else
if(is.list(x)) as.data.frame(x) else
if(is.vector(x)) data.frame(x=x) else
stop("unable to handle supplied data", call. = FALSE)
###################
#possible issue if
#x shorter than y - as above
###################
#need a lim checker/out of range handler
#need
if(is.vector(y))
data.xy$y <- if(length(y) < nrow(data.xy))
rep(y, ceiling(nrow(data.xy)/length(y)))[1:nrow(data.xy)] else
y[1:nrow(data.xy)]
#check dim
if(ncol(data.xy) < 2)
stop("insufficient data for 'xy' assignment", call. = FALSE)
#force.abc/rescale
temp <- data.xy[,1:2]
if(force.xy){
if("x" %in% names(data.xy)) temp[,1] <- data.xy$x
if("y" %in% names(data.xy)) temp[,2] <- data.xy$y
}
data.xy <- temp
a <- data.xy[,2]/(1.1 *0.866) * 1 #comfirm 1.1
b <- (data.xy[,1] - (a * 0.5))
c <- 1 - (a+b)
ans <- list(a=a, b=b, c=c)
if(!verbose) return(ans)
listUpdate(ans, list(x=data.xy[,1], y=data.xy[,2]))
}
#################################################
#triABCSquareGrid
#################################################
#needs work
triABCSquareGrid <- function(a, b = NULL, c = NULL, ..., n=100){
#currently this expected three data series
#but overrides if a/b/clim are present
#tested with
#ans <- triABCSquareGrid(alim=c(0,1), blim=c(0,1), clim=c(0,1), n=20)
# with(ans, trianglePlot(a*b*c~a+b+c))
#maybe test with a/b/c inputs later.
extra.args <- list(...)
if(all(c("alim", "blim", "clim") %in% names(extra.args))){
#use the lims to make grid
a <- c(min(extra.args$alim, na.rm=TRUE), max(extra.args$alim, na.rm=TRUE), min(extra.args$alim, na.rm=TRUE))
b <- c(min(extra.args$blim, na.rm=TRUE), min(extra.args$blim, na.rm=TRUE), max(extra.args$blim, na.rm=TRUE))
c <- c(max(extra.args$clim, na.rm=TRUE), min(extra.args$clim, na.rm=TRUE), min(extra.args$clim, na.rm=TRUE))
} else {
extra.args <- listUpdate(list(alim=c(0,1), blim=c(0,1), clim=c(0,1)), extra.args)
}
xy <- triABC2XY(a, b, c)
x <- seq(min(xy$x, na.rm=TRUE), max(xy$x, na.rm=TRUE), length.out=n)
y <- seq(min(xy$y, na.rm=TRUE), max(xy$y, na.rm=TRUE), length.out=n)
grd <- list(x=rep(x, each=length(y)), y=rep(y, length(x)))
grd <- data.frame(as.data.frame(do.call(triXY2ABC, grd)), as.data.frame(grd))
#tidy grd
grd <- grd[grd[,1] >= min(extra.args$alim, na.rm=TRUE) & grd[,1] <= max(extra.args$alim, na.rm=TRUE),]
grd <- grd[grd[,2] >= min(extra.args$blim, na.rm=TRUE) & grd[,2] <= max(extra.args$blim, na.rm=TRUE),]
grd <- grd[grd[,3] >= min(extra.args$clim, na.rm=TRUE) & grd[,3] <= max(extra.args$clim, na.rm=TRUE),]
#drop x and y?
grd <- grd[c("a", "b", "c")]
#make unique?
as.list(grd)
}
Try the loa 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.