Nothing
R/cond.handlers.R
In loa: Lattice Options and Add-Ins
Defines functions
stepwiseZcasesGlyphHandler
groupsAndZcasesHandler
zcasesHandler
groupsHandler
condsPanelHandler
groupsPanelHandler
zcasesPanelHandler
groupsAndZcasesPanelHandler
Documented in
condsPanelHandler
groupsAndZcasesHandler
groupsAndZcasesPanelHandler
groupsHandler
groupsPanelHandler
stepwiseZcasesGlyphHandler
zcasesHandler
zcasesPanelHandler
#in development code
#[TBC - NUMBER] functions
#cond handlers
#do properly
###########################
###########################
#
###########################
###########################
groupsAndZcasesPanelHandler <- function(panel=NULL, ..., plot = TRUE, process = TRUE){
#wrapper for groupsPanelHandler and zcasesPanelHandler
temp <- names(list(...))
if(!"groups" %in% temp & !"zcases" %in% temp)
panel(...) else if(!"groups" %in% temp)
zcasesPanelHandler(..., panel = panel, plot = plot, process = process) else if(!"zcases" %in% temp)
groupsPanelHandler(..., panel = panel, plot = plot, process = process) else {
#this is currently not fully working
#here we know we have both groups and zcases
#reset args
extra.args <- list(...)
extra.args$cond.args <- unique(c(extra.args$group.args,
extra.args$zcase.args))
extra.args$conds <- paste(extra.args$groups,
extra.args$zcases,
sep = "#by#")
##could rationalise the next two bits?
##
if("group.args" %in% names(extra.args))
for(i in extra.args$group.args)
extra.args[[i]] <- rep(extra.args[[i]], length(extra.args$zcase.ids))
if("zcase.args" %in% names(extra.args))
for(i in extra.args$zcase.args)
extra.args[[i]] <- rep(extra.args[[i]], each = length(extra.args$zcase.ids))
#chop out groups, etc
extra.args <- extra.args[!names(extra.args) %in% c("groups", "group.ids", "zcases", "zcase.ids")]
do.call(condsPanelHandler, listUpdate(extra.args,
list(panel=panel, plot=plot, process=process,
reset.conds = c("groups","zcases"))))
}
}
#####################################
zcasesPanelHandler <- function(..., zcases = NULL, panel = NULL, by.zcase = NULL,
process = TRUE, plot = TRUE){
#restructure
#so we can use groupsHandler code
extra.args <- list(...)
if(!"cond.args" %in% names(extra.args))
extra.args$cond.args <- extra.args$zcase.args
if(is.null(extra.args$panel.elements)){
temp <- lapply(extra.args, function(x) length(x) == length(extra.args$x))
extra.args$panel.elements <- names(extra.args)[temp]
}
extra.args$cond.ids <- if(is.null(extra.args$zcase.ids))
if(is.factor(zcases)) levels(zcases) else unique(zcases) else
extra.args$zcase.ids
extra.args <- listUpdate(extra.args,
list(panel = panel, conds = zcases,
by.cond = by.zcase, reset.conds = "zcases",
process = process, plot = plot))
#run
do.call(condsPanelHandler, extra.args)
}
###########################################
groupsPanelHandler <- function(..., groups = NULL, panel = NULL, by.group = NULL,
process = TRUE, plot = TRUE){
#restructure
#so we can use groupsHandler code
extra.args <- list(...)
if(!"cond.args" %in% names(extra.args))
extra.args$cond.args <- extra.args$group.args
if(is.null(extra.args$panel.elements)){
temp <- lapply(extra.args, function(x) length(x) == length(extra.args$x))
extra.args$panel.elements <- names(extra.args)[temp]
}
extra.args$cond.ids <- if(is.null(extra.args$group.ids))
if(is.factor(groups)) levels(groups) else unique(groups) else
extra.args$group.ids
extra.args <- listUpdate(extra.args,
list(panel = panel, conds = groups,
by.cond = by.group, reset.conds = "groups",
process = process, plot = plot))
#run
do.call(condsPanelHandler, extra.args)
}
#############################################
condsPanelHandler <- function(..., conds = NULL, panel = NULL, by.cond = NULL,
process = TRUE, plot = TRUE){
##think about this
##process and plot need to be passed on
#extra.args <- list(...)
extra.args <- listUpdate(list(...), list(process=process, plot=plot))
if(is.null(panel) && is.null(by.cond)) return(NULL)
if(!process && !plot) return(NULL)
if(is.null(conds)) return(do.call(panel, extra.args))
if(is.null(by.cond))
by.cond <- list(panel)
cond.ids <- if(is.null(extra.args$cond.ids))
if(is.factor(conds)) levels(conds) else unique(conds) else
extra.args$cond.ids
#might want to rename this
#might be fine
panel.elements <- if(is.null(extra.args$panel.elements)){
#if not known
#assume we want all that are the same length as x
#could be bad for col.regions
temp <- lapply(extra.args, function(x) length(x) == length(extra.args$x))
names(extra.args)[temp]
} else extra.args$panel.elements
n <- rep(1:length(by.cond), length.out = length(cond.ids))
##could the next bit be reduced/simplify
if(process & !plot){
#the process method
out <- lapply(1:length(n), function(i){
#process and plot
#or plot only
#or null case
temp <- extra.args[names(extra.args) %in% panel.elements]
temp <- lapply(temp, function(x) x[conds == cond.ids[i]])
temp <- listUpdate(extra.args, temp)
for(j in temp$cond.args)
temp[[j]] <- temp[[j]][i]
# temp[names(temp) %in% c(temp$cond.args] <- temp[names(temp) %in% c(temp$cond.args][i]
out2 <- if(is.list(by.cond[[n[i]]])) do.call(panel, listUpdate(temp, by.cond[[n[i]]])) else
if(is.function(by.cond[[n[i]]])) do.call(by.cond[[n[i]]], temp)
ref <- if(is.null(out2$x)) out2[[1]] else out2$x
out2$conds <- cond.ids[i]
#this is the bit that gets renamed
#in each of the functions
if("reset.conds" %in% names(extra.args)){
if(length(extra.args$reset.conds) > 1) {
for(k in 1:length(extra.args$reset.conds)){
out2[[extra.args$reset.conds[k]]] <- unlist(lapply(strsplit(out2$conds, "#by#"), function(x) x[k]))
}
} else {
names(out2)[names(out2) == "conds"] <- extra.args$reset.conds
}
out2 <- out2[names(out2)[!names(out2) %in% "conds"]]
}
temp <- temp[names(temp) %in% panel.elements]
temp <- temp[!names(temp) %in% names(out2)]
temp <- lapply(temp, function(x) rep(x, length.out=length(ref)))
listUpdate(out2, temp)
})
####merge the lists
out <- as.list(do.call(rbind, lapply(out, function(x) as.data.frame(x, stringsAsFactors=FALSE))))
} else {
for(i in 1:length(n)){
#this needs to be better
#terminates badly
#process and plot
#or plot only
#or null case
temp <- extra.args[names(extra.args) %in% panel.elements]
temp <- lapply(temp, function(x) x[conds == cond.ids[i]])
temp <- listUpdate(extra.args, temp)
for(j in temp$cond.args)
temp[[j]] <- temp[[j]][i]
temp$subscripts <- 1:length(temp$x)
##########################
#new bit
#now passing this cond.id function
temp$local.cond.id <- cond.ids[i]
# temp[names(temp) %in% c(temp$cond.args] <- temp[names(temp) %in% c(temp$cond.args][i]
if(is.list(by.cond[[n[i]]])) do.call(panel, listUpdate(temp, by.cond[[n[i]]]))
if(is.function(by.cond[[n[i]]])) do.call(by.cond[[n[i]]], temp)
}
}
}
###########################
###########################
#
###########################
###########################
groupsHandler <- function(z = NULL, groups = NULL, ..., group.ids = NULL,
handler = "zzz"){
#setup
extra.args <- list(...)
#do nothing if groups not set
if(is.null(groups)) return(z)
#if groups and group.ids set
#group.ids should be robust
group.ids <- unique(c(group.ids,
if(is.factor(groups)) levels(groups) else groups))
#assign z
if(is.null(z)){
#if z is absent set groups as default
z <- groups
#this could be restructured
#we also assume this needs handling
known.handlers <- c("col", "cex", "pch")
if(handler %in% known.handlers){
temp <- as.numeric(factor(group.ids, levels=group.ids))
extra.args$z <- temp
extra.args$ref <- NULL
extra.args <- extra.args[names(extra.args) != "zlim"]
z <- do.call(paste(handler[1], "Handler", sep=""), extra.args)
} else {
z <- as.numeric(factor(group.ids))
}
} else {
#if z is present set groups robustly
z <- zHandler(z = z, ref = group.ids)
#transpose onto groups
##here ##z <- z[as.numeric(factor(groups, group.ids))]
#we assume this is fine for 'as.is' use
#because this is what the user set arg as
}
#output
z
}
############################################
#fix
################################
#to be checked should this
#be zcases.ids or zcase.ids
################################
zcasesHandler <- function(z = NULL, zcases = NULL, ..., zcases.ids = NULL,
handler = "zzz"){
#restructure
#so we can use groupsHandler code
extra.args <- listUpdate(list(...),
list(z = z, handler=handler,
groups = zcases,
group.ids = zcases.ids))
do.call(groupsHandler, extra.args)
}
#############################################
groupsAndZcasesHandler <- function(..., loa.settings = NULL){
#set up
extra.args <- list(...)
if(is.null(loa.settings))
loa.settings <- list()
#tidy this
#groups and zcases to formals
#groups and zcase overlap test to top
#check for groups
if("groups" %in% names(extra.args)){
if(is.null(extra.args$group.ids))
extra.args$group.ids <- if(is.factor(extra.args$groups))
levels(extra.args$groups) else unique(extra.args$groups)
if(is.null(extra.args$group.args))
extra.args$group.args <- loa.settings$group.args
extra.args$ignore <- unique(c(extra.args$ignore, extra.args$group.args))
for(i in extra.args$group.args)
extra.args[[i]] <- do.call(groupsHandler,
listUpdate(extra.args,
list(z = extra.args[[i]], handler=i)))
}
#check for zcases
if("zcases" %in% names(extra.args)){
if(is.null(extra.args$zcase.ids))
extra.args$zcase.ids <- if(is.factor(extra.args$zcases))
levels(extra.args$zcases) else unique(extra.args$zcases)
if(is.null(extra.args$zcase.args))
extra.args$zcase.args <- loa.settings$zcase.args
#to think through
#if zcases and groups are set
#common args need to be compared
if("groups" %in% names(extra.args)){
#print(
#any(extra.args$zcase.args %in% extra.args$group.args)
#)
if(any(extra.args$zcase.args %in% extra.args$group.args)){
temp <- extra.args$zcase.args[!extra.args$zcase.args %in% extra.args$group.args]
if(length(temp)<1){
extra.args$zcase.args <- NULL
warning("zcase.args/group.args conflict\n",
"no requested args not already applied by groups", call.=FALSE)
} else {
extra.args$zcase.args <- temp
warning("zcase.args/group.args conflict\n",
"one or more requested args already applied by groups", call.=FALSE)
}
}
}
extra.args$ignore <- unique(c(extra.args$ignore, extra.args$zcase.args))
for(i in extra.args$zcase.args)
extra.args[[i]] <- do.call(zcasesHandler,
listUpdate(extra.args,
list(z = extra.args[[i]], handler=i)))
}
extra.args
}
###########################################################
stepwiseZcasesGlyphHandler <- function(zcases = NULL, ..., zcase.ids = NULL,
panel.elements = NULL, loaGlyph = NULL){
#########################
#stepwise Glyph handler
#where glyph elements are
#by zcases
#########################
######################
#set up
######################
extra.args <- list(...)
#########################
#checks
#########################
if(is.null(zcases)){
#stop?
}
if(is.null(loaGlyph)){
#stop?
}
if(is.null(panel.elements)){
#make a substitute panel.elements
}
if(is.null(zcase.ids)){
#make substitute zcase.ids
zcase.ids <- if(is.factor(zcases))
levels(zcases) else unique(zcases)
}
#######################
#main variables
#######################
zcase.count <- length(zcase.ids)
zcase.len <- max(sapply(zcase.ids, function(x) length(extra.args$x[zcases==x])))
#might want to think about warning if different x cases are different
#might want to drop x from test?
#this would simplify if we assumed all zcases were same length
#which I think we can?
for(a in 1:zcase.len){
for(b in 1:zcase.count){
temp <- extra.args
temp$zrow.ids <- temp$z[seq(a, length(extra.args$z), zcase.len)]
for(i in panel.elements){
temp[[i]] <- temp[[i]][zcases == zcase.ids[b]][a]
}
if("zcase.args" %in% names(extra.args)){
for(i in extra.args$zcase.args){
temp[[i]] <- extra.args[[i]][zcase.ids==zcase.ids[b]]
}
}
#could move a lot of the following out of formals?
temp$zcase.ref <- c(b, zcase.count)
temp$zcase.ids <- zcase.ids
temp$count.ref <- c(a, zcase.len)
do.call(loaGlyph, temp)
}
}
}
Try the loa package in your browser
Any scripts or data that you put into this service are public.
loa documentation built on Dec. 25, 2024, 3 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 stepwiseZcasesGlyphHandler groupsAndZcasesHandler zcasesHandler groupsHandler condsPanelHandler groupsPanelHandler zcasesPanelHandler groupsAndZcasesPanelHandler
Documented in condsPanelHandler groupsAndZcasesHandler groupsAndZcasesPanelHandler groupsHandler groupsPanelHandler stepwiseZcasesGlyphHandler zcasesHandler zcasesPanelHandler
#in development code
#[TBC - NUMBER] functions
#cond handlers
#do properly
###########################
###########################
#
###########################
###########################
groupsAndZcasesPanelHandler <- function(panel=NULL, ..., plot = TRUE, process = TRUE){
#wrapper for groupsPanelHandler and zcasesPanelHandler
temp <- names(list(...))
if(!"groups" %in% temp & !"zcases" %in% temp)
panel(...) else if(!"groups" %in% temp)
zcasesPanelHandler(..., panel = panel, plot = plot, process = process) else if(!"zcases" %in% temp)
groupsPanelHandler(..., panel = panel, plot = plot, process = process) else {
#this is currently not fully working
#here we know we have both groups and zcases
#reset args
extra.args <- list(...)
extra.args$cond.args <- unique(c(extra.args$group.args,
extra.args$zcase.args))
extra.args$conds <- paste(extra.args$groups,
extra.args$zcases,
sep = "#by#")
##could rationalise the next two bits?
##
if("group.args" %in% names(extra.args))
for(i in extra.args$group.args)
extra.args[[i]] <- rep(extra.args[[i]], length(extra.args$zcase.ids))
if("zcase.args" %in% names(extra.args))
for(i in extra.args$zcase.args)
extra.args[[i]] <- rep(extra.args[[i]], each = length(extra.args$zcase.ids))
#chop out groups, etc
extra.args <- extra.args[!names(extra.args) %in% c("groups", "group.ids", "zcases", "zcase.ids")]
do.call(condsPanelHandler, listUpdate(extra.args,
list(panel=panel, plot=plot, process=process,
reset.conds = c("groups","zcases"))))
}
}
#####################################
zcasesPanelHandler <- function(..., zcases = NULL, panel = NULL, by.zcase = NULL,
process = TRUE, plot = TRUE){
#restructure
#so we can use groupsHandler code
extra.args <- list(...)
if(!"cond.args" %in% names(extra.args))
extra.args$cond.args <- extra.args$zcase.args
if(is.null(extra.args$panel.elements)){
temp <- lapply(extra.args, function(x) length(x) == length(extra.args$x))
extra.args$panel.elements <- names(extra.args)[temp]
}
extra.args$cond.ids <- if(is.null(extra.args$zcase.ids))
if(is.factor(zcases)) levels(zcases) else unique(zcases) else
extra.args$zcase.ids
extra.args <- listUpdate(extra.args,
list(panel = panel, conds = zcases,
by.cond = by.zcase, reset.conds = "zcases",
process = process, plot = plot))
#run
do.call(condsPanelHandler, extra.args)
}
###########################################
groupsPanelHandler <- function(..., groups = NULL, panel = NULL, by.group = NULL,
process = TRUE, plot = TRUE){
#restructure
#so we can use groupsHandler code
extra.args <- list(...)
if(!"cond.args" %in% names(extra.args))
extra.args$cond.args <- extra.args$group.args
if(is.null(extra.args$panel.elements)){
temp <- lapply(extra.args, function(x) length(x) == length(extra.args$x))
extra.args$panel.elements <- names(extra.args)[temp]
}
extra.args$cond.ids <- if(is.null(extra.args$group.ids))
if(is.factor(groups)) levels(groups) else unique(groups) else
extra.args$group.ids
extra.args <- listUpdate(extra.args,
list(panel = panel, conds = groups,
by.cond = by.group, reset.conds = "groups",
process = process, plot = plot))
#run
do.call(condsPanelHandler, extra.args)
}
#############################################
condsPanelHandler <- function(..., conds = NULL, panel = NULL, by.cond = NULL,
process = TRUE, plot = TRUE){
##think about this
##process and plot need to be passed on
#extra.args <- list(...)
extra.args <- listUpdate(list(...), list(process=process, plot=plot))
if(is.null(panel) && is.null(by.cond)) return(NULL)
if(!process && !plot) return(NULL)
if(is.null(conds)) return(do.call(panel, extra.args))
if(is.null(by.cond))
by.cond <- list(panel)
cond.ids <- if(is.null(extra.args$cond.ids))
if(is.factor(conds)) levels(conds) else unique(conds) else
extra.args$cond.ids
#might want to rename this
#might be fine
panel.elements <- if(is.null(extra.args$panel.elements)){
#if not known
#assume we want all that are the same length as x
#could be bad for col.regions
temp <- lapply(extra.args, function(x) length(x) == length(extra.args$x))
names(extra.args)[temp]
} else extra.args$panel.elements
n <- rep(1:length(by.cond), length.out = length(cond.ids))
##could the next bit be reduced/simplify
if(process & !plot){
#the process method
out <- lapply(1:length(n), function(i){
#process and plot
#or plot only
#or null case
temp <- extra.args[names(extra.args) %in% panel.elements]
temp <- lapply(temp, function(x) x[conds == cond.ids[i]])
temp <- listUpdate(extra.args, temp)
for(j in temp$cond.args)
temp[[j]] <- temp[[j]][i]
# temp[names(temp) %in% c(temp$cond.args] <- temp[names(temp) %in% c(temp$cond.args][i]
out2 <- if(is.list(by.cond[[n[i]]])) do.call(panel, listUpdate(temp, by.cond[[n[i]]])) else
if(is.function(by.cond[[n[i]]])) do.call(by.cond[[n[i]]], temp)
ref <- if(is.null(out2$x)) out2[[1]] else out2$x
out2$conds <- cond.ids[i]
#this is the bit that gets renamed
#in each of the functions
if("reset.conds" %in% names(extra.args)){
if(length(extra.args$reset.conds) > 1) {
for(k in 1:length(extra.args$reset.conds)){
out2[[extra.args$reset.conds[k]]] <- unlist(lapply(strsplit(out2$conds, "#by#"), function(x) x[k]))
}
} else {
names(out2)[names(out2) == "conds"] <- extra.args$reset.conds
}
out2 <- out2[names(out2)[!names(out2) %in% "conds"]]
}
temp <- temp[names(temp) %in% panel.elements]
temp <- temp[!names(temp) %in% names(out2)]
temp <- lapply(temp, function(x) rep(x, length.out=length(ref)))
listUpdate(out2, temp)
})
####merge the lists
out <- as.list(do.call(rbind, lapply(out, function(x) as.data.frame(x, stringsAsFactors=FALSE))))
} else {
for(i in 1:length(n)){
#this needs to be better
#terminates badly
#process and plot
#or plot only
#or null case
temp <- extra.args[names(extra.args) %in% panel.elements]
temp <- lapply(temp, function(x) x[conds == cond.ids[i]])
temp <- listUpdate(extra.args, temp)
for(j in temp$cond.args)
temp[[j]] <- temp[[j]][i]
temp$subscripts <- 1:length(temp$x)
##########################
#new bit
#now passing this cond.id function
temp$local.cond.id <- cond.ids[i]
# temp[names(temp) %in% c(temp$cond.args] <- temp[names(temp) %in% c(temp$cond.args][i]
if(is.list(by.cond[[n[i]]])) do.call(panel, listUpdate(temp, by.cond[[n[i]]]))
if(is.function(by.cond[[n[i]]])) do.call(by.cond[[n[i]]], temp)
}
}
}
###########################
###########################
#
###########################
###########################
groupsHandler <- function(z = NULL, groups = NULL, ..., group.ids = NULL,
handler = "zzz"){
#setup
extra.args <- list(...)
#do nothing if groups not set
if(is.null(groups)) return(z)
#if groups and group.ids set
#group.ids should be robust
group.ids <- unique(c(group.ids,
if(is.factor(groups)) levels(groups) else groups))
#assign z
if(is.null(z)){
#if z is absent set groups as default
z <- groups
#this could be restructured
#we also assume this needs handling
known.handlers <- c("col", "cex", "pch")
if(handler %in% known.handlers){
temp <- as.numeric(factor(group.ids, levels=group.ids))
extra.args$z <- temp
extra.args$ref <- NULL
extra.args <- extra.args[names(extra.args) != "zlim"]
z <- do.call(paste(handler[1], "Handler", sep=""), extra.args)
} else {
z <- as.numeric(factor(group.ids))
}
} else {
#if z is present set groups robustly
z <- zHandler(z = z, ref = group.ids)
#transpose onto groups
##here ##z <- z[as.numeric(factor(groups, group.ids))]
#we assume this is fine for 'as.is' use
#because this is what the user set arg as
}
#output
z
}
############################################
#fix
################################
#to be checked should this
#be zcases.ids or zcase.ids
################################
zcasesHandler <- function(z = NULL, zcases = NULL, ..., zcases.ids = NULL,
handler = "zzz"){
#restructure
#so we can use groupsHandler code
extra.args <- listUpdate(list(...),
list(z = z, handler=handler,
groups = zcases,
group.ids = zcases.ids))
do.call(groupsHandler, extra.args)
}
#############################################
groupsAndZcasesHandler <- function(..., loa.settings = NULL){
#set up
extra.args <- list(...)
if(is.null(loa.settings))
loa.settings <- list()
#tidy this
#groups and zcases to formals
#groups and zcase overlap test to top
#check for groups
if("groups" %in% names(extra.args)){
if(is.null(extra.args$group.ids))
extra.args$group.ids <- if(is.factor(extra.args$groups))
levels(extra.args$groups) else unique(extra.args$groups)
if(is.null(extra.args$group.args))
extra.args$group.args <- loa.settings$group.args
extra.args$ignore <- unique(c(extra.args$ignore, extra.args$group.args))
for(i in extra.args$group.args)
extra.args[[i]] <- do.call(groupsHandler,
listUpdate(extra.args,
list(z = extra.args[[i]], handler=i)))
}
#check for zcases
if("zcases" %in% names(extra.args)){
if(is.null(extra.args$zcase.ids))
extra.args$zcase.ids <- if(is.factor(extra.args$zcases))
levels(extra.args$zcases) else unique(extra.args$zcases)
if(is.null(extra.args$zcase.args))
extra.args$zcase.args <- loa.settings$zcase.args
#to think through
#if zcases and groups are set
#common args need to be compared
if("groups" %in% names(extra.args)){
#print(
#any(extra.args$zcase.args %in% extra.args$group.args)
#)
if(any(extra.args$zcase.args %in% extra.args$group.args)){
temp <- extra.args$zcase.args[!extra.args$zcase.args %in% extra.args$group.args]
if(length(temp)<1){
extra.args$zcase.args <- NULL
warning("zcase.args/group.args conflict\n",
"no requested args not already applied by groups", call.=FALSE)
} else {
extra.args$zcase.args <- temp
warning("zcase.args/group.args conflict\n",
"one or more requested args already applied by groups", call.=FALSE)
}
}
}
extra.args$ignore <- unique(c(extra.args$ignore, extra.args$zcase.args))
for(i in extra.args$zcase.args)
extra.args[[i]] <- do.call(zcasesHandler,
listUpdate(extra.args,
list(z = extra.args[[i]], handler=i)))
}
extra.args
}
###########################################################
stepwiseZcasesGlyphHandler <- function(zcases = NULL, ..., zcase.ids = NULL,
panel.elements = NULL, loaGlyph = NULL){
#########################
#stepwise Glyph handler
#where glyph elements are
#by zcases
#########################
######################
#set up
######################
extra.args <- list(...)
#########################
#checks
#########################
if(is.null(zcases)){
#stop?
}
if(is.null(loaGlyph)){
#stop?
}
if(is.null(panel.elements)){
#make a substitute panel.elements
}
if(is.null(zcase.ids)){
#make substitute zcase.ids
zcase.ids <- if(is.factor(zcases))
levels(zcases) else unique(zcases)
}
#######################
#main variables
#######################
zcase.count <- length(zcase.ids)
zcase.len <- max(sapply(zcase.ids, function(x) length(extra.args$x[zcases==x])))
#might want to think about warning if different x cases are different
#might want to drop x from test?
#this would simplify if we assumed all zcases were same length
#which I think we can?
for(a in 1:zcase.len){
for(b in 1:zcase.count){
temp <- extra.args
temp$zrow.ids <- temp$z[seq(a, length(extra.args$z), zcase.len)]
for(i in panel.elements){
temp[[i]] <- temp[[i]][zcases == zcase.ids[b]][a]
}
if("zcase.args" %in% names(extra.args)){
for(i in extra.args$zcase.args){
temp[[i]] <- extra.args[[i]][zcase.ids==zcase.ids[b]]
}
}
#could move a lot of the following out of formals?
temp$zcase.ref <- c(b, zcase.count)
temp$zcase.ids <- zcase.ids
temp$count.ref <- c(a, zcase.len)
do.call(loaGlyph, temp)
}
}
}
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.