-
Notifications
You must be signed in to change notification settings - Fork 0
Expand file tree
/
Copy pathapp1a.R
More file actions
127 lines (103 loc) · 2.87 KB
/
Copy pathapp1a.R
File metadata and controls
127 lines (103 loc) · 2.87 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
projection.object <- function() {
v <- vector('list',length=10)
names(v) <- c('ID','status','proj','fixed','target','wtf','wtt','wtr','olds','current')
get.object <- function() {
return(v)
}
set.id <- function(s) {
stopifnot(length(s) == 2)
stopifnot(v$ID == NULL)
v$ID <<- s
}
set.status <- function(status) {
stopifnot(v$ID != NULL)
stopifnot(status %in% c(0,1))
v$status <<- status
}
set.proj <- function(mat) {
if(v$proj == NULL) {
v$proj <<- mat
}
}
}
copy.projection.object <- function() {
}
}
new.cepp <- function(data,objlist,slots,name='cepp') {
#Shared Variable definitions
backend <- function() {
make.frame <- function() {
}
}
interact.ggobi <- function() {
g <- numeric(1)
init.ggobi <- function() {
}
get.number.of.brushes <- function() {
}
}
cepp.widget <- function() {
}
}
xnames <- paste('x',1:(length(objlist) + slots),sep='')
ynames <- paste('y',1:(length(objlist) + slots),sep='')
projdim <- dim(objlist[[1]])[2]
nr <- nrow(data)
nc <- nrow(data)
l <- vector('list',length=length(objlist)+slots)
g <- 0
#Initializations
for(i in 1:length(l)) {
l[[i]] <- projection()
l[[i]]$ID <- c(xnames[i],ynames[i])
l[[i]]$fixed <- NULL
l[[i]]$target <- NULL
l[[i]]$wtf <- 0
l[[i]]$wtt <- 0
l[[i]]$wtr <- 1
l[[i]]$olds <- NULL
if(i <= length(objlist)) {
l[[i]]$status <- 1
l[[i]]$proj <- objlist[[i]]
}
else {
l[[i]]$status <- 0
l[[i]]$proj <- matrix(0,nrow=nr,ncol=projdim)
}
l[[i]]$current <- data %*% l[[i]]$proj
}
#Functions go here
projection <- function() {
v <- vector('list',length=10)
names(v) <- c('status','proj','ID','fixed','target','wtf','wtt','wtr','olds','current')
return(v)
}
selection <- function() {
v <- vector('list',length=2)
names(v) <- c('colour','glyph')
return(v)
}
make.frame <- function() {
#Called only during Initialization
frame <- do.call(cbind,lapply(l,FUN=function(x) x$current))
colnames(frame) <- 1:dim(b)[2]
colnames(frame)[seq(1,dim(frame)[2],2)] <- paste('x',1:(dim(frame)[2]/2),sep='')
colnames(frame)[seq(2,dim(frame)[2],2)] <- paste('y',1:(dim(frame)[2]/2),sep='')
return(frame)
}
init.ggobi <- function(data,projs,slots,name='cepp') {
#projs is a list of projection matrices
#slots is the number of empty slots requested
frame <- make.frame()
g <<- ggobi(frame,name=name)
lapply(l,FUN = display,x=g[1],vars=list(X=xnames[i],Y=ynames[i]))
}
ggobi.id.to.string <- function(i) names(c(variables(displays(g)[[i]])$X,variables(displays(g)[[i]])$Y))
get.glyph.group <- function() {}
get.color.group <- function() {}
information(id) {
i <- which(sapply(l,FUN=function(x) x$ID) == id)
if(l[[i]]$status == 0) return("This slot is inactive")
else
}
}