-
Notifications
You must be signed in to change notification settings - Fork 0
/
tcs_plot.R
178 lines (154 loc) · 6.49 KB
/
tcs_plot.R
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
#' Call this to start building a TCS plot.
#' Will clear all previously added TCS data.
#'
#' @param colour_background The graph's background colour.
#' @param colour_text The graph's text colour.
#' @param colour_wl_long The colour to use for the long wavelength corner.
#' @param colour_wl_medium The colour to use for the medium wavelength corner.
#' @param colour_wl_short The colour to use for the short wavelength corner.
#' @param colour_wl_uv The colour to use for the UV wavelength corner.
#' @param colour_achro The colour to use for the achromatic centre.
#' @param colour_selection The colour to use for the indicator around the selected point.
#' @param colour_highlight The colour to use for the indicator around the highlighted point.
#' @param colour_metric_line The colour to use for the lines when displaying metrics.
#' @param colour_metric_fill The colour to use for the filled arcs when displaying metrics.
#' @param point_size The default size to use for data points.
#' @param corner_size The size to use for the spheres in the corners of the tetrahedron.
#' @param sphere_quality The quality of the spheres, as an integer >= 5.
#' @param render_mode The render mode to use, either 'fast' or 'slow'.
#'
tcs.begin <- function(colour_background = NULL, colour_text = NULL,
colour_wl_long = NULL, colour_wl_medium = NULL,
colour_wl_short = NULL, colour_wl_uv = NULL,
colour_achro = NULL, colour_selection = NULL,
colour_highlight = NULL, colour_metric_line = NULL,
colour_metric_fill = NULL, point_size = NULL,
corner_size = NULL, sphere_quality = NULL,
render_mode = c("fast", "slow"))
{
tcsEnv <<- new.env()
tcsEnv$data <- c("<?xml version=\"1.0\"?>", "<data>")
params <<- unlist(as.list(match.call()))[-1]
if (length(params) > 0)
{
tcsEnv$data <- c(tcsEnv$data, "<style>")
for (i in seq_along(params))
{
name <- names(params)[i]
value <- params[i][1]
if (substring(name, 1, 6) == "colour")
{
name <- substring(name, 8)
format <- '<colour id="%s">%s</colour>'
}
else
{
format <- '<setting id="%s">%s</setting>'
}
tcsEnv$data <- c(tcsEnv$data, sprintf(format, name, value))
}
tcsEnv$data <- c(tcsEnv$data, "</style>")
}
}
#' Adds a number of points to the current plot.
#' @param data TCS data containing the points to add.
#' Must either be a colspace object from the package pavo,
#' or a data frame/matrix with the first three columns being
#' theta, phi and r (magnitude).
#' @param name The name of the group of points.
#' @param colours A vector specifying the colours of the points.
#' @param shape The shape to use for the points.
#' @param size The size of the points. Overrides the size specified
#' in tcs.begin() for this data group.
tcs.points <- function(data, labels = NULL, name = NULL, colours = "#000",
shape = c("sphere", "box", "pyramid"), size = NULL)
{
if (!exists("tcsEnv"))
stop("Must call tcs.begin before tcs.points!")
if (is(data, "colspace"))
{
data <- data[,c("h.theta", "h.phi", "r.vec")]
}
colours <- rep(colours, length.out = nrow(data))
if (is.null(labels))
{
labels <- row.names(data)
}
groupAttributes <- character(0)
if (!is.null(name))
groupAttributes <- c(groupAttributes, sprintf('name="%s"', name))
if (!is.null(size))
groupAttributes <- c(groupAttributes, sprintf('size="%s"', size))
groupAttributes <- c(groupAttributes, sprintf('shape="%s"', shape[1]))
openTag <- sprintf('<group %s>', paste(groupAttributes, collapse = " "))
tcsEnv$data <- c(tcsEnv$data, openTag)
tcsEnv$data <- c(tcsEnv$data, unlist(lapply(1:nrow(data), function(i)
{
position <- paste(data[i,], collapse = ",")
return(paste0("<point ", "name=\"", labels[i], "\" colour=\"", colours[i], "\" position=\"", position, "\"/>"))
})))
tcsEnv$data <- c(tcsEnv$data, "</group>")
}
#' Adds one or more volumes to the current plot.
#' @param data A list of TCS data containing the points to form the volumes from.
#' Each element in the list must either be a colspace object from the package pavo,
#' or a data frame/matrix with the first three columns being
#' theta, phi and r (magnitude).
#' @param colours A vector specifying the colours of the volumes.
tcs.volumes <- function(data, colours = "#000")
{
if (!exists("tcsEnv"))
stop("Must call tcs.begin before tcs.volumes!")
if (!is.list(data))
stop("data must be a list!")
colours <- rep(colours, length.out = length(data))
invisible(lapply(1:length(data), function(i)
{
tcs.volume(data[[i]], colours[i])
}))
}
#' Adds a volume mesh to the plot based on a number of points.
#' @param data TCS data containing the points to base the volume on.
#' Must either be a colspace object from the package pavo,
#' or a data frame/matrix with the first three columns being
#' theta, phi and r (magnitude).
#' @param colour A character specifying the colour of the volume.
tcs.volume <- function(data, colour = "#000")
{
if (!exists("tcsEnv"))
stop("Must call tcs.begin before tcs.volume!")
if (is(data, "colspace"))
{
data <- data[,c("h.theta", "h.phi", "r.vec")]
}
tcsEnv$data <- c(tcsEnv$data, paste0("<volume colour=\"", colour, "\">"))
tcsEnv$data <- c(tcsEnv$data, unlist(apply(data, 1, paste, collapse = ",")))
tcsEnv$data <- c(tcsEnv$data, "</volume>")
}
#' Saves the current TCS data to a file, launches the plot viewer,
#' and removes the TCS data storage.
#' @param file The output file to save the TCS data to.
#' @param jarPath Path to the TetraColourSpace .jar file. May be NULL
#' (in which case the plot is not displayed).
tcs.end <- function(file, jarPath = NULL, outputPath = NULL, async = F)
{
if (!exists("tcsEnv"))
stop("Must call tcs.begin before tcs.end!")
tcsEnv$data <- c(tcsEnv$data, "</data>")
file.create(file)
connection <- file(file)
writeLines(tcsEnv$data, connection)
close(connection)
rm(tcsEnv, envir = .GlobalEnv)
if (!is.null(jarPath))
tcs.launch(file, jarPath, outputPath, async)
}
#' Launches the specified jar-file with the provided graph file and output path.
tcs.launch <- function(file, jarPath, outputPath = NULL, async = F)
{
if (is.null(outputPath))
command <- sprintf("java -jar \"%s\" \"%s\"", jarPath, file)
else
command <- sprintf("java -jar \"%s\" \"%s\" \"%s\"", jarPath, file, outputPath)
system(command, wait = !async)
}