# R/fluctuations2.R In extracat: Categorical Data Analysis and Visualization

#### Defines functions scale2scale1simplerectrecursilefluctileXT

```fluctileXT <- function(x, hsplit = TRUE, split = "r", fun = NULL, col = NULL, gap.prop = 0.05, plotfun, plotdim = length(dim(x))-2, border = NULL, label = TRUE, add = FALSE, ...  ){

dims <- as.list(dim(x))
nd <- length(dims)

#split directions init
if(length(hsplit) == 1){
hsplit <- rep( c(hsplit,!hsplit),nd )[1:nd]
}
if(length(hsplit) < nd){
hsplit <- rep( hsplit,nd )[1:nd]
}

###### -------------------------------------------------------------------------- #####
###### ----------------------------    LAYOUT ETC   ----------------------------- #####

nx <- min(sum(hsplit*label),2)
ny <- min(sum(!hsplit*label),2)

if(is.null(border)){
border <- 0.1
}
if(length(border) == 1){
border <- 	border * c( nx/(nx+1),1/(nx+1),1/(ny+1), ny/(ny+1) )
}
if(length(border) == 2){
border <- 	c( border[1] * c( nx/(nx+1),1/(nx+1)) , border[2] * c( ny/(ny+1),1/(ny+1)) )
}

###### -------------------------------------------------------------------------- #####
###### -------------------------------------------------------------------------- #####

hsplit <- as.list(hsplit)

# prepare plotting for correct dimension
plot <- as.list(rep(FALSE,nd))
plot[[plotdim]] <- TRUE
plotfun <- substitute(plotfun)

print(plotfun)
# transformations
fun <- as.list(rep(fun,nd))[1:nd]

# splitting rule
split <- as.list(rep(split,nd))[1:nd]

# gap.prop
gap.prop <- as.list(rep(gap.prop,nd))[1:nd]

# viewport names and environment
e1 <- environment()
ltrs <- expand.grid(letters,letters,letters)
vpn <- paste(ltrs[,1],ltrs[,2],ltrs[,3],sep="")
k <- 0

# TODO: color palette

#base viewport:
grid.newpage()
}
grandparent <- viewport(x = border[1] + (1-border[1]-border[2])/2 , y = border[3] + (1-border[3]-border[4])/2, width = 1-border[1]-border[2], height = 1-border[3]-border[4],name="base")

dynasty <- recursile( z = x, parent = grandparent, dims = dims, hsplit = hsplit , split = split,
fun =  fun , col = col , gap.prop = gap.prop , plot = plot, env = e1)

return(invisible(dynasty))
}

recursile <- function( z, parent ,dims, hsplit , split, fun , gap.prop ,  env, plot, col = NULL, ...  ){

pushViewport(parent)
nv <- dims[[1]]
dims

if(!is.null(fun[[1]])){
z <- fun[[1]](z)
}
# col similar?

if(plot[[1]]){
# do the plotting
#print(env\$plotfun)
#plotcall <- call(env\$plotfun)
#plotcall[[2]] <- z
#plotcall[[3]] <- env\$col
#for(i in seq_along(env\$args)){
#	plotcall[[3+i]] <- env\$args[[i]]
#}
if(!is.null(col)){
env\$plotfun[[ length(env\$plotfun) + 1 ]] <- col
names(env\$plotfun)[length(env\$plotfun)] <- "col"
}
try(
subplot <- eval(env\$plotfun, list(x = z, vp = parent))
)
popViewport()
return(invisible(parent))
}else{

# relative or equal splits:

if(split[[1]] %in% c("r","rel","relative")){
if(is.null(dim(z))){
w <- z/sum(z)
}else{
w <- apply(z,1,sum)
w <- w/sum(w)
}
print(w)
}else{
# more options?
w <- rep(1/nv,nv)
}
w <-   w * (1-gap.prop[[1]])   # rep((1-gap.prop[[1]])/nv,nv)
x <-  (0:(nv-1)) * gap.prop[[1]]/(nv-1) + cumsum(w) - w/2
h <- rep(1,nv)
y <- rep(0.5,nv)

children <- vpList()

if(is.null(dim(z))){
z <- as.list(z)

for(i in 1:nv){
env\$k <- env\$k+1
if(!hsplit[[1]]){

tmp <- viewport( y[i],1-x[i],h[i],w[i],just="centre" , name = env\$vpn[env\$k])
children[[i]] <- recursile( z[[i]][[1]], parent = tmp, dims =  NULL, hsplit =  NULL , split =  NULL,
fun =   NULL , gap.prop = NULL , plot = TRUE, env = env, col = col)
}else{
tmp <- viewport( x[i],y[i],w[i],h[i],just="centre" , name = env\$vpn[env\$k])
children[[i]] <- recursile( z[[i]][[1]], parent = tmp, dims =  NULL, hsplit =  NULL , split =  NULL,
fun =   NULL , gap.prop = NULL , plot = TRUE, env = env, col = col)
}

}

}else{
z <- apply(z,1,list)
for(i in 1:nv){
env\$k <- env\$k+1
if(!hsplit[[1]]){
tmp <- viewport( y[i],1-x[i],h[i],w[i],just="centre" , name = env\$vpn[env\$k])
children[[i]] <- recursile( z[[i]][[1]], parent = tmp, dims = dims[-1], hsplit = hsplit[-1] , split = split[-1],
fun =  fun[-1] , gap.prop = gap.prop[-1] , plot = plot[-1], env = env, col = col)
}else{
tmp <- viewport( x[i],y[i],w[i],h[i],just="centre" , name = env\$vpn[env\$k])
children[[i]] <- recursile( z[[i]][[1]], parent = tmp, dims = dims[-1], hsplit = hsplit[-1] , split = split[-1],
fun =  fun[-1] , gap.prop = gap.prop[-1] , plot = plot[-1], env = env, col = col)
}

}

}

}

popViewport()

return(invisible(vpTree(parent,children)))

}

simplerect <- function(x, dir = "b", just = "c", col = alpha(1,0.5), bg = "lightgrey", vp = NULL){
fill <- col

if(length(just) == 1){
just <- rep(just,2)
}
if(just[1] %in% c("r","right")){
just[1] <- "right"
xc <- 1
}
if(just[1] %in% c("l","left")){
just[1] <- "left"
xc <- 0
}
if(just[2] %in% c("t","top")){
just[2] <- "top"
yc <- 1
}
if(just[2] %in% c("b","bottom")){
just[2] <- "bottom"
yc <- 0
}
if(just[1] %in% c("c","centre", "center")){
just[1] <- "centre"
xc <- 0.5
}
if(just[2] %in% c("c","centre", "center")){
just[2] <- "centre"
yc <- 0.5
}

if(dir %in% c("b","both")){

ht <- min(1,x)
wt <- min(1,x)
}
if(dir %in% c("h","horizontal",2)){

wt <- min(1,x)
ht <- 1
}
if(dir %in% c("v","vertical",1)){

wt <- 1
ht <- min(1,x)
}
if(dir %in% c("n","none")){

ht <- 1
wt <- 1
if(x==0){
fill <- "white"
}
}

grid.rect(x = 0.5, y = 0.5, width = 1, height = 1, just = "centre", default.units = "npc",
name = NULL, gp = gpar(col = NA, fill = bg),
draw = TRUE, vp = vp)

grid.rect(x = xc, y = yc, width = wt, height = ht, just = just, default.units = "npc",
name = NULL, gp = gpar(col = col, fill = fill),
draw = TRUE, vp = vp)

return(invisible(TRUE))
}

scale1<-function(x) x/sum(x)

scale2<-function(x) x/max(x)
```

## Try the extracat package in your browser

Any scripts or data that you put into this service are public.

extracat documentation built on July 17, 2018, 5:05 p.m.