Nothing
R/vrmlgen-internal.R
In vrmlgen: Generate 3D visualizations for data exploration on the web
# helper function to apply the automatic coloring of
# labeled datapoints in different plotting functions
`.colorselection` <-
function (type = "cloud", index, cols, numpoints, labels, numlabels)
{
# automatic coloring for bar plot functions
if (type == "bar") {
if (length(cols) == length(labels)) {
rcol <- (col2rgb(cols[index])/255)[1]
gcol <- (col2rgb(cols[index])/255)[2]
bcol <- (col2rgb(cols[index])/255)[3]
}
else if (length(cols) == 1) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
}
else {
rcol <- (col2rgb("black")/255)[1]
gcol <- (col2rgb("black")/255)[2]
bcol <- (col2rgb("black")/255)[3]
}
}
# automatic coloring for 3D cloud and mesh plots
else {
if (!length(cols)) {
rcol <- (col2rgb(rainbow(numpoints)[index])/255)[1]
gcol <- (col2rgb(rainbow(numpoints)[index])/255)[2]
bcol <- (col2rgb(rainbow(numpoints)[index])/255)[3]
}
else if ((length(cols) == 1) || ((length(cols) < numpoints) &&
!length(labels))) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
}
else if (length(labels) && (length(cols) == length(unique(labels))) &&
(type != "mesh")) {
rcol <- (col2rgb(cols[numlabels[index]])/255)[1]
gcol <- (col2rgb(cols[numlabels[index]])/255)[2]
bcol <- (col2rgb(cols[numlabels[index]])/255)[3]
}
else {
rcol <- (col2rgb(cols[index])/255)[1]
gcol <- (col2rgb(cols[index])/255)[2]
bcol <- (col2rgb(cols[index])/255)[3]
}
}
return(list(rcol = rcol, gcol = gcol, bcol = bcol))
}
# creating bar plots in Livegraphics3D-format
`.lbar` <-
function (data, row.labels = rownames(data), col.labels = colnames(data),
filename = "out.m", space = 0.5, cols = rainbow(length(as.matrix(data))),
rcols = NULL, ccols = NULL, origin = c(0, 0, 0), scalefac = 4, autoscale = TRUE,
ignore_zeros = TRUE, lab.axis = c("X-axis", "Y-axis", "Z-axis"), col.axis = "black",
showaxis = TRUE, col.lab = "black", col.bg = "white", cex.lab = 1,
cex.rowlab = 1, cex.collab = 1, ambientlight = 0.5, htmlout = NULL,
hwidth = 1200, hheight = 800, showlegend = TRUE)
{
data <- as.matrix(data)
curdir <- NULL
# verify if .lbar is called within a vrmlgen-environment
# initialized with lg3d.open()
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write LiveGraphics3D header
write("Graphics3D[\n{\n", file = filename, append = FALSE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}", sep = " "), file = filename,
append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# scale the data to fit within the axes ranges
if(autoscale)
data <- scalefac * (data/max(data))
# pre-process row- and column-labels
if (!is.null(col.labels) && showlegend)
col.labels <- sapply(strsplit(col.labels, " "), function(x) paste(x,
collapse = "\n"))
if (!is.null(row.labels) && showlegend)
row.labels <- sapply(strsplit(row.labels, " "), function(x) paste(x,
collapse = "\n"))
# calculate bar-length and -width (account for scaling and spacing)
blength <- scalefac/(nrow(data) * (1 + space))
bwidth <- scalefac/(ncol(data) * (1 + space))
# draw the axes
if (showaxis) {
# call the axis3d helper function to draw the axes
axis3d(lab.axis, filename, type = "lg3d", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
# draw row-labels
if (!is.null(row.labels) && showlegend) {
for (j in 1:length(row.labels)) {
# apply automatic color selection
colsel <- .colorselection(type = "bar", j, rcols,
1, row.labels, "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
cur_xwidth <- j/nrow(data) * scalefac - blength/2
write(paste("RGBColor[", rcol, ",", gcol, ",", bcol,
"], Text [ \"", row.labels[j], "\", {", cur_xwidth,
",", -0.4, ",", scalefac + 0.2, "}],\n", sep = ""),
file = filename, append = TRUE)
}
}
# draw column-labels
if (!is.null(col.labels) && showlegend) {
for (j in 1:length(col.labels)) {
# apply automatic color selection
colsel <- .colorselection(type = "bar", j, ccols,
1, col.labels, "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
cur_ywidth <- j/ncol(data) * scalefac - bwidth/2
write(paste("RGBColor[", rcol, ",", gcol, ",", bcol,
"], Text [ \"", col.labels[j], "\", {", -0.4,
",", cur_ywidth, ",", scalefac + 0.2, "}],\n",
sep = ""), file = filename, append = TRUE)
}
}
rcol <- NULL
gcol <- NULL
bcol <- NULL
# set RGB-colors
if (length(cols) >= (ncol(data) * nrow(data))) {
rcol <- sapply(cols, function(x) (col2rgb(x)/255)[1])
gcol <- sapply(cols, function(x) (col2rgb(x)/255)[2])
bcol <- sapply(cols, function(x) (col2rgb(x)/255)[3])
}
else {
if (length(cols) >= 1) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
}
else {
rcol <- (col2rgb("lightblue")/255)[1]
gcol <- (col2rgb("lightblue")/255)[2]
bcol <- (col2rgb("lightblue")/255)[3]
}
}
# main loop: iterate over data points
bwidth <- bwidth/2
for (k in 1:ncol(data)) {
for (j in 1:nrow(data)) {
x <- j/nrow(data) * scalefac
y <- k/ncol(data) * scalefac
z <- data[j, k]
if(ignore_zeros && (z == 0))
next
# set current color
if (!is.null(ccols)) {
rcol <- (col2rgb(ccols[k])/255)[1]
gcol <- (col2rgb(ccols[k])/255)[2]
bcol <- (col2rgb(ccols[k])/255)[3]
}
else if (!is.null(rcols)) {
rcol <- (col2rgb(rcols[j])/255)[1]
gcol <- (col2rgb(rcols[j])/255)[2]
bcol <- (col2rgb(rcols[j])/255)[3]
}
else {
if(length(rcol) > 1)
{
rcol <- rcol[(k - 1) * ncol(data) +
j]
gcol <- gcol[(k - 1) * ncol(data) +
j]
bcol <- bcol[(k - 1) * ncol(data) +
j]
}
}
# draw data point
write(paste("SurfaceColor[RGBColor[", rcol, ",",
gcol, ",", bcol, "]], Cuboid[{", origin[1] +
x - bwidth, ",", origin[2] + y - bwidth, ",",
origin[3], "},{", origin[1] + x + bwidth, ",",
origin[2] + y + bwidth, ",", origin[3] + z, "}],",
sep = ""), file = filename, append = TRUE)
}
}
# configure general plot settings (font size, text style, etc.)
write(paste("\n}, Boxed -> False, Axes -> False, AmbientLight->GrayLevel[",
ambientlight, "], TextStyle -> {FontFamily -> \"TimesRoman\", FontSlant ->\"Italic\", FontSize -> ",
14 * cex.lab, "}, Lighting -> True, BoxRatios -> Automatic, PlotRange -> All ]\n",
sep = ""), file = filename, append = TRUE)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY>",
file = htmlout, append = TRUE)
cat(paste("<APPLET ARCHIVE=\"live.jar\" CODE=\"Live.class\" WIDTH=",
hwidth, " HEIGHT=", hheight, " ALIGN=LEFT>",
sep = ""), file = htmlout, append = TRUE)
coln <- col2rgb(col.bg)
cat(paste("<PARAM NAME=\"BGCOLOR\" VALUE=\"", rgb(red = coln[1,
]/255, green = coln[2, ]/255, blue = coln[3,
]/255), "\">", sep = ""), file = htmlout, append = TRUE)
cat("<PARAM NAME=\"MAGNIFICATION\" VALUE=1.0>", file = htmlout,
append = TRUE)
cat(paste("<PARAM NAME=\"INPUT_FILE\" VALUE=\"",
filename, "\">", sep = ""), file = htmlout, append = TRUE)
cat("</APPLET>", file = htmlout, append = TRUE)
cat("</HTML>", file = htmlout, append = TRUE)
}
# copy the Livegraphics3D live.jar to the output directory
datadir <- system.file("extdata", package = "vrmlgen")
curdir <- getwd()
# use if file.exists
if (data.class(result<-try(file.copy(file.path(datadir, "live.jar"), file.path(curdir, "live.jar")), TRUE))=="try-error")
{
warning("\nCannot copy file live.jar from vrlmgen-folder to current directory. You might need to copy the file manually.")
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# creating scatter plots in Livegraphics3D-format
`.lcloud` <-
function (x, y = NULL, z = NULL, labels = rownames(data), metalabels = NULL,
hyperlinks = NULL, filename = "out.m", pointstyle = c("s",
"b", "t"), cols = rainbow(length(unique(labels))), scalefac = 4,
autoscale = "independent", lab.axis = c("X-axis", "Y-axis",
"Z-axis"), col.axis = "black", showaxis = TRUE, col.lab = "black",
col.metalab = "black", col.bg = "white", cex.lab = 1, ambientlight = 0.5,
htmlout = NULL, hwidth = 1200, hheight = 800, showlegend = TRUE)
{
# extract the coordinate vectors from the input
xyz_parse <- xyz.coords(x, y, z)
data <- cbind(xyz_parse$x, xyz_parse$y, xyz_parse$z)
if (ncol(data) != 3) {
stop("Data matrix does not have 3 columns!")
}
# identify the unique set of row labels
numlabels <- NULL
if (length(labels)) {
lab <- unique(unlist(labels))
numlabels <- apply(as.matrix(labels), 1, function(x) match(x,
as.matrix(lab)))
}
# verify if .lcloud is called within a vrmlgen-environment
# initialized with lg3d.open()
curdir <- NULL
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
write("Graphics3D[\n{\n", file = filename, append = FALSE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}, \n", sep = " "), file = filename,
append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# apply the chosen scaling method
scaledat <- function(data) {
diff <- max(data) - min(data)
if (diff == 0)
return(data)
else return(scalefac * (data - min(data))/(diff))
}
if (autoscale == "independent")
data <- apply(data, 2, scaledat)
else if (autoscale == "equidist")
data <- scalefac * (data/max(data))
# create the plot legend
if (length(labels) && showlegend) {
cur_height <- scalefac + 1 + cex.lab/5
for (j in 1:length(unique(labels))) {
# write text using the lower-level text
# drawing function
.lg3dtext(0, 0, cur_height, unique(labels)[j], filename,
cols[unique(numlabels)[j]], 1, "Arial", "Plain",
NULL)
cur_height <- cur_height + 0.4
}
}
# draw the axes
lab_rcol <- NULL
lab_gcol <- NULL
lab_bcol <- NULL
ax_rcol <- NULL
ax_gcol <- NULL
ax_bcol <- NULL
if (showaxis) {
# call the axis3d helper function to draw the axes
axis3d(lab.axis, filename, type = "lg3d", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
# use empty metalabels if only url-labels have been defined
if ((length(metalabels) == 0) && (length(hyperlinks) >= 1)) {
metalabels <- rep(" ", length(hyperlinks))
}
# main loop: iterate over data points
for (j in 1:nrow(data)) {
x <- data[j, 1]
y <- data[j, 2]
z <- data[j, 3]
# apply automatic color selection
colsel <- .colorselection(type = "cloud", j, cols, nrow(data),
labels, numlabels)
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
# draw data points with given point-style
if (length(pointstyle) == 1) {
.lg3dpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle, hyperlinks = NULL, local_scale = 1)
}
else if (length(pointstyle) >= length(unique(numlabels))) {
if (length(labels)) {
stylevec <- c("s", "b", "t")
curstyle <- stylevec[numlabels[j]]
.lg3dpoints(x, y, z, filename, rcol, gcol, bcol,
curstyle, hyperlinks = NULL, local_scale = 1)
}
else {
.lg3dpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle[1], hyperlinks = NULL, local_scale = 1)
}
}
else {
.lg3dpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle[1], hyperlinks = NULL, local_scale = 1)
}
if (length(metalabels) >= j) {
frcol <- (col2rgb(col.metalab)/255)[1]
fgcol <- (col2rgb(col.metalab)/255)[2]
fbcol <- (col2rgb(col.metalab)/255)[3]
# add metalabels and hyperlinks
write(paste("Text[StyleForm[\"", metalabels[j], "\",FontFamily -> \"Arial\", FontWeight->\"Bold\", FontColor -> RGBColor[",
frcol, ",", fgcol, ",", fbcol, "], FontSize->9,",
sep = ""), file = filename, append = TRUE)
if (length(hyperlinks) >= j) {
write(paste("URL -> \"", hyperlinks[j], ",target=_blank\",",
sep = ""), file = filename, append = TRUE)
}
write(paste("],{", x, ",", y, ",", z, "}],", sep = ""),
file = filename, append = TRUE)
}
}
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
write(paste("\n}, Boxed -> False, Axes -> False, AmbientLight->GrayLevel[",
ambientlight, "], TextStyle -> {FontFamily -> \"TimesRoman\", FontSlant ->\"Italic\", FontSize -> ",
14 * cex.lab, "}, Lighting -> True, BoxRatios -> Automatic, PlotRange -> All ]\n",
sep = ""), file = filename, append = TRUE)
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY>",
file = htmlout, append = TRUE)
cat(paste("<APPLET ARCHIVE=\"live.jar\" CODE=\"Live.class\" WIDTH=",
hwidth, " HEIGHT=", hheight, " ALIGN=LEFT>",
sep = ""), file = htmlout, append = TRUE)
coln <- col2rgb(col.bg)
cat(paste("<PARAM NAME=\"BGCOLOR\" VALUE=\"", rgb(red = coln[1,
]/255, green = coln[2, ]/255, blue = coln[3,
]/255), "\">", sep = ""), file = htmlout, append = TRUE)
cat("<PARAM NAME=\"MAGNIFICATION\" VALUE=1.0>", file = htmlout,
append = TRUE)
cat(paste("<PARAM NAME=\"INPUT_FILE\" VALUE=\"",
filename, "\">", sep = ""), file = htmlout, append = TRUE)
cat("</APPLET></BODY>", file = htmlout, append = TRUE)
cat("</HTML>", file = htmlout, append = TRUE)
}
# copy the Livegraphics3D live.jar to the output directory
datadir <- system.file("extdata", package = "vrmlgen")
curdir <- getwd()
if (data.class(result<-try(file.copy(file.path(datadir, "live.jar"), file.path(curdir, "live.jar")), TRUE))=="try-error")
{
warning("\nCannot copy file live.jar from vrlmgen-folder to current directory. You might need to copy the file manually.")
}
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# lower-level function for plotting data points in the Livegraphics3D-format
`.lg3dpoints` <-
function (x, y, z, filename, rcol, gcol, bcol, pointstyle, hyperlinks = NULL,
global_scale = 1, local_scale = 1)
{
# check the point-style and draw the data points at the
# corresponding coordinates
if (pointstyle == "s") {
for (i in 1:length(x))
write(paste("PointSize[", 0.02 *
local_scale, "], RGBColor[", rcol, ",",
gcol, ",", bcol, "], Point[{", x[i],
",", y[i], ",", z[i],
"}],", sep = ""), file = filename, append = TRUE)
}
else if (pointstyle == "t") {
for (i in 1:length(x))
write(paste("{ SurfaceColor[RGBColor[",
rcol, ",", gcol, ",", bcol, "]], Polygon[{{", local_scale *
x[i], ", ", local_scale * y[i], ",", local_scale *
(z[i] + 0.06415), "}, {", local_scale * global_scale *
(x[i] + 0.09072222), ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] -
0.096225), "}, {", local_scale * global_scale *
x[i] - 0.09072222, ",", local_scale * global_scale *
y[i] + 0.15713333, ",", local_scale * global_scale *
z[i] - 0.096225, "}}], Polygon[{{", local_scale *
global_scale * x[i], ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] +
0.06415), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] + 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] - 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}}], Polygon[{{", local_scale *
global_scale * x[i], ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] +
0.06415), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] - 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}, {", local_scale * global_scale *
(x[i] + 0.09072222), ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] -
0.096225), "}}], Polygon[{{", local_scale * global_scale *
(x[i] + 0.09072222), ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] -
0.096225), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] - 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] + 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}}] },\n", sep = ""), file = filename,
append = TRUE)
}
else {
for (i in 1:length(x))
write(paste("SurfaceColor[RGBColor[",
rcol, ",", gcol, ",", bcol, "]], Cuboid[{", local_scale *
(x[i] - 0.04), ",", local_scale * (y[i] - 0.04),
",", local_scale * (z[i] - 0.04), "},{", local_scale *
global_scale * (x[i] + 0.04), ",", local_scale *
global_scale * (y[i] + 0.04), ",", local_scale *
global_scale * (z[i] + 0.04), "}],", sep = ""),
file = filename, append = TRUE)
}
# add hyperlinks to the datapoints
if (!is.null(hyperlinks)) {
for (i in 1:length(hyperlinks))
write(paste("Text[StyleForm[\" \", URL -> \"",
hyperlinks, "\"], {", local_scale * x[i], ",", local_scale *
y[i], ",", local_scale * z[i], "}],", sep = ""),
file = filename, append = TRUE)
}
}
# lower-level function for adding text to a 3D-scene
# in the Livegraphics3D-format
`.lg3dtext` <-
function (x, y, z, text, filename, col, scale, fontfamily, fontweight,
hyperlink)
{
# convert the color to RGB-format
rcol <- (col2rgb(col)/255)[1]
gcol <- (col2rgb(col)/255)[2]
bcol <- (col2rgb(col)/255)[3]
# add hyperlinks to the text
if (is.null(hyperlink)) {
for (i in 1:length(x))
write(paste("RGBColor[", rcol,
",", gcol, ",", bcol, "], Text [StyleForm[\"", text[i],
"\", FontFamily -> \"", fontfamily, "\", FontSize-> ",
14 * scale, ", FontWeight->\"", fontweight, "\"], {",
x[i], ",", y[i], ",", z[i], "}],\n", sep = ""), file = filename,
append = TRUE)
}
else {
for (i in 1:length(x))
write(paste("RGBColor[", rcol,
",", gcol, ",", bcol, "], Text [StyleForm[\"", text[i],
"\", FontFamily -> \"", fontfamily, "\", FontSize-> ",
14 * scale, ", URL -> \"", hyperlink, "\", FontWeight->\"",
fontweight, "\"], {", x[i], ",", y[i], ",", z[i],
"}],\n", sep = ""), file = filename, append = TRUE)
}
}
# creating 3D-meshes in Livegraphics3D-format
`.lmesh` <-
function (xfun = "sin(v)*cos(u)", yfun = "sin(v)*sin(u)", zfun = "cos(v)",
param1 = "u", param2 = "v", range1 = c(0, 2 * pi), range2 = c(0,
pi), size1 = 30, size2 = 30, filename = "out.m", cols = "red",
scalefac = 4, autoscale = "independent", lab.axis = c("X-axis",
"Y-axis", "Z-axis"), col.axis = "black", showaxis = TRUE,
col.lab = "black", col.bg = "white", cex.lab = 1, ambientlight = 0.5,
htmlout = NULL, hwidth = 1200, hheight = 800)
{
# check if the required input data is available
if (is.null(xfun) || is.null(yfun) || is.null(zfun)) {
stop("Either the paramater infile or data or the parameters xfun, yfun and zfun have to be specified.")
}
if (is.null(param1) || is.null(param2)) {
stop("The parameter names param1 and param2 have not been specified")
}
# initialize variables
x <- NULL
y <- NULL
z <- NULL
smin <- range1[1]
smax <- range1[2]
tmin <- range2[1]
tmax <- range2[2]
sn <- size1
tn <- size2
ds <- (smax - smin)/sn
dt <- (tmax - tmin)/tn
# compute the data points representing the parametric function
for (i in seq(smin, (smax - ds/2), ds)) {
for (j in seq(tmin, (tmax - dt/2), dt)) {
eval(parse(text = paste(param1, " <- ", i)))
eval(parse(text = paste(param2, " <- ", j)))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param1, " <- ", param1, " + ds")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param2, " <- ", param2, " + dt")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param1, " <- ", param1, " - ds")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
}
}
# combine data
data <- as.matrix(cbind(x, y, z))
if (ncol(data) != 3) {
stop("Data matrix does not have 3 columns!")
}
# verify if .lmesh is called within a vrmlgen-environment
# initialized with lg3d.open()
curdir <- NULL
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write LiveGraphics3D header
write("Graphics3D[\n{\n", file = filename, append = FALSE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}", sep = " "), file = filename,
append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# apply the chosen scaling method
scaledat <- function(data) {
diff <- max(data) - min(data)
if (diff == 0)
return(data)
else return(scalefac * (data - min(data))/(diff))
}
if (autoscale == "independent")
data <- apply(data, 2, scaledat)
else if (autoscale == "equidist")
data <- scalefac * (data/max(data))
else if (autoscale == "equicenter")
data <- scalefac/2 * data/max(data) + scalefac/2
lab_rcol <- NULL
lab_gcol <- NULL
lab_bcol <- NULL
ax_rcol <- NULL
ax_gcol <- NULL
ax_bcol <- NULL
# draw the axes
if (showaxis) {
axis3d(lab.axis, filename, type = "lg3d", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
for (j in 1:nrow(data)) {
x <- data[j, 1]
y <- data[j, 2]
z <- data[j, 3]
# apply automatic color selection
colsel <- .colorselection(type = "mesh", j, cols, nrow(data),"", "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
if (j%%4 == 1)
write(paste(" SurfaceColor[RGBColor[", rcol, ",",
gcol, ",", bcol, "]], Polygon[{{", x, ",", y,
",", z, "},", sep = ""), file = filename, append = TRUE)
else if (j%%4 == 0)
write(paste(" {", x, ",", y, ",", z, "}}],", sep = ""),
file = filename, append = TRUE)
else write(paste(" {", x, ",", y, ",", z, "},", sep = ""),
file = filename, append = TRUE)
}
# configure general plot settings (font size, text style, etc.)
write(paste("\n}, Boxed -> False, Axes -> False, AmbientLight->GrayLevel[",
ambientlight, "], TextStyle -> {FontFamily -> \"TimesRoman\", FontSlant ->\"Italic\", FontSize -> ",
14 * cex.lab, "}, Lighting -> True, BoxRatios -> Automatic, PlotRange -> All ]\n",
sep = ""), file = filename, append = TRUE)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY>",
file = htmlout, append = TRUE)
cat(paste("<APPLET ARCHIVE=\"live.jar\" CODE=\"Live.class\" WIDTH=",
hwidth, " HEIGHT=", hheight, " ALIGN=LEFT>",
sep = ""), file = htmlout, append = TRUE)
coln <- col2rgb(col.bg)
cat(paste("<PARAM NAME=\"BGCOLOR\" VALUE=\"", rgb(red = coln[1,
]/255, green = coln[2, ]/255, blue = coln[3,
]/255), "\">", sep = ""), file = htmlout, append = TRUE)
cat("<PARAM NAME=\"MAGNIFICATION\" VALUE=1.0>", file = htmlout,
append = TRUE)
cat(paste("<PARAM NAME=\"INPUT_FILE\" VALUE=\"",
filename, "\">", sep = ""), file = htmlout, append = TRUE)
cat("</APPLET>", file = htmlout, append = TRUE)
cat("</HTML>", file = htmlout, append = TRUE)
}
# copy the Livegraphics3D live.jar to the output directory
datadir <- system.file("extdata", package = "vrmlgen")
curdir <- getwd()
if (data.class(result<-try(file.copy(file.path(datadir, "live.jar"), file.path(curdir, "live.jar")), TRUE))=="try-error")
{
warning("\nCannot copy file live.jar from vrlmgen-folder to current directory. You might need to copy the file manually.")
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# helper function to combine rotation vectors
# by quaternion multiplication
`.multquaternion` <-
function (q1, q2)
{
tmp <- numeric(4)
tmp[1] = q2[4] * q1[1] + q2[1] * q1[4] + q2[2] * q1[3] -
q2[3] * q1[2]
tmp[2] = q2[4] * q1[2] + q2[2] * q1[4] + q2[3] * q1[1] -
q2[1] * q1[3]
tmp[3] = q2[4] * q1[3] + q2[3] * q1[4] + q2[1] * q1[2] -
q2[2] * q1[1]
tmp[4] = q2[4] * q1[4] - q2[1] * q1[1] - q2[2] * q1[2] -
q2[3] * q1[3]
return(tmp)
}
# helper function to represent rotation vectors
# by quaternions
`.quaternion2rot` <-
function (quat)
{
res <- numeric(4)
res[4] = acos(quat[4]) * 2
for (i in 1:3) res[i] = quat[i]/sin(res[4]/2)
return(res)
}
# helper function to convert quaternion representations
# of rotation vectors back to the normal representation
`.rot2quaternion` <-
function (rot = c(1, 0, 0, pi))
{
res <- numeric(4)
for (i in 1:3) res[i] <- rot[i] * sin(rot[4]/2)
res[4] <- cos(rot[4]/2)
return(res)
}
# creating bar plots in VRML-format
`.vbar` <-
function (data, row.labels = rownames(data), col.labels = colnames(data),
metalabels = NULL, filename = "out.wrl", space = 0.5, cols = rainbow(length(as.matrix(data))),
rcols = NULL, ccols = NULL, origin = c(0, 0, 0), scalefac = 4, autoscale = TRUE,
ignore_zeros = TRUE, lab.axis = c("X-axis", "Y-axis", "Z-axis"), lab.vertical = FALSE,
col.axis = "black", showaxis = TRUE, col.lab = "black", col.bg = "white",
cex.lab = 1, cex.rowlab = 1, cex.collab = 1, navigation = "EXAMINE",
fov = 0.785, pos = rep(scalefac + 4, 3), dir = c(0.19, 0.45,
0.87, 2.45), transparency = 0, htmlout = NULL, hwidth = 1200,
hheight = 800, showlegend = TRUE)
{
data <- as.matrix(data)
# verify if .vbar is called within a vrmlgen-environment
# initialized with vrml.open()
scale <- 1
curdir <- NULL
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write VRML header
write("#VRML V2.0 utf8\n", file = filename, append = FALSE)
write(paste("\nViewpoint {\n\tfieldOfView", fov, "\n\tposition",
pos[1], pos[2], pos[3], "\n\torientation", dir[1],
dir[2], dir[3], dir[4], "\n\tjump TRUE\n\tdescription \"viewpoint1\"\n}\n",
sep = " "), file = filename, append = TRUE)
write(paste("\nNavigationInfo { type \"", navigation,
"\" }\n", sep = ""), file = filename, append = TRUE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}", sep = " "), file = filename,
append = TRUE)
}
else {
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
scale <- vrmlgenEnv$scale
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# scale the data to fit within the axes ranges
if(autoscale)
data <- scale * scalefac * (data/max(data))
# configure popup-text for metalabels
popuptext <- TRUE
if (is.null(metalabels)) {
popuptext <- FALSE
}
# generate popup-text
if (popuptext)
write(paste("\n\nPROTO PopupText [\n\teventIn MFString showThis\n\texposedField SFNode fontStyle FontStyle {\n\t\t\t\tjustify [ \"MIDDLE\", \"MIDDLE\" ] }\n\texposedField SFNode appearance Appearance { material Material { } } \n\tfield SFString default \"\" \n\tfield MFString stringlist [ \"\" ] \n",
paste(paste("eventIn SFBool over", 0:(length(metalabels) -
1), "\n\t", sep = "", collapse = ""), sep = "",
collapse = ""), "\t] { \nGroup { children [ \n\tDEF POPIT Script { \n\t\tfield SFString defstring IS default \n\t\tfield MFString list IS stringlist \n\t\tfield MFString strout [ \"\" ] ",
paste(paste("\n eventIn SFBool over", 0:(length(metalabels) -
1), " IS over", 0:(length(metalabels) - 1), sep = "",
collapse = "")), "\n\t\teventOut MFString string_changed \n\t\turl [ \"javascript: \n\t\tfunction evtnum(num, value) \n\t\t{ \n\t\tif (value && (num < list.length)) \n\t\t\tstrout[0] = list[num]; \n\t\telse \n\t\t\tstrout[0] = defstring; \n\t\tstring_changed = strout; \n\t\t} \n \n\t",
paste(paste("\tfunction over", 0:(length(metalabels) -
1), "(v, t) { evtnum(", 0:(length(metalabels) -
1), ", v); } \n", sep = "", collapse = "")),
"\t\", \n\t\t\"Popup.class\"] \n\t} \n\t \n\tTransform { \n\ttranslation 0 0 ",
scale * scalefac, " \n\trotation 0.28108 0.67860 0.67860 2.59356\n\t \n\tchildren Shape { \n\t\tappearance IS appearance \n\tgeometry DEF POPUP Text { \n\t\tstring \"\" \n\t\tset_string IS showThis \n\t\tfontStyle IS fontStyle \n\t\t} \n\t} \n\t} \n] } \nROUTE POPIT.string_changed TO POPUP.set_string \n} \n \n \nGroup { \nchildren DEF POP PopupText { \n\t\t#default \"Nothing selected\" \n\t\tstringlist [ ",
paste(paste("\"", metalabels[1:(length(metalabels) -
1)], "\",", sep = "", collapse = " ")), "\"",
metalabels[length(metalabels)], "\" ] \n\t} \n} \n\n",
sep = "", collapse = ""), file = filename, append = TRUE)
# draw the axes
if (showaxis) {
axis3d(lab.axis, filename, type = "vrml", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
# calculate bar-length and -width (account for scaling and spacing)
blength <- scale * scalefac/(nrow(data) * (1 + space))
bwidth <- scale * scalefac/(ncol(data) * (1 + space))
# rotate the data labels to obtain horizontal or vertical labels
rot_vec <- c(0, 0.70711, 0.70711, 3.14159)
if (lab.vertical)
rot_vec <- c(0.57735, 0.57735, 0.57735, 4.18879)
# draw row-labels
if (!is.null(row.labels) && showlegend) {
for (j in 1:length(row.labels)) {
# apply automatic color selection
colsel <- .colorselection(type = "bar", j, rcols,
1, row.labels, "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
cur_xwidth <- j/nrow(data) * scale * scalefac - blength/2
write(paste("Transform {\n\ttranslation ", cur_xwidth,
-0.4, scale * scalefac + 0.2, "\n\tscale ", cex.rowlab *
0.28, cex.rowlab * 0.28, cex.rowlab * 0.28,
"\n\trotation ", rot_vec[1], rot_vec[2], rot_vec[3],
rot_vec[4], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material {diffuseColor ",
rcol, " ", gcol, " ", bcol, " } }\n\t\tgeometry Text { string \"",
row.labels[j], "\" }\n\t}\n}", sep = " "), file = filename,
append = TRUE)
}
}
# rotate the data labels to obtain horizontal or vertical labels
rot_vec <- c(0.57735, 0.57735, 0.57735, 2.0944)
if (lab.vertical)
rot_vec <- c(0.707107, 0, 0.707107, 3.14159)
# draw column-labels
if (!is.null(col.labels) && showlegend) {
for (j in 1:length(col.labels)) {
# apply automatic color selection
colsel <- .colorselection(type = "bar", j, ccols,
1, col.labels, "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
cur_ywidth <- j/ncol(data) * scale * scalefac - bwidth/2
write(paste("Transform {\n\ttranslation ", -0.4,
cur_ywidth, scale * scalefac + 0.2, "\n\tscale ",
cex.collab * 0.28, cex.collab * 0.28, cex.collab *
0.28, "\n\trotation ", rot_vec[1], rot_vec[2],
rot_vec[3], rot_vec[4], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material {diffuseColor ",
rcol, " ", gcol, " ", bcol, " } }\n\t\tgeometry Text { string \"",
col.labels[j], "\" }\n\t}\n}", sep = " "), file = filename,
append = TRUE)
}
}
# initialize color and meta-label variables
popup_txt_str <- ""
popup_txt_str2 <- ""
rcol <- NULL
gcol <- NULL
bcol <- NULL
# set RGB-colors
if (length(cols) >= (ncol(data) * nrow(data))) {
rcol <- sapply(cols, function(x) (col2rgb(x)/255)[1])
gcol <- sapply(cols, function(x) (col2rgb(x)/255)[2])
bcol <- sapply(cols, function(x) (col2rgb(x)/255)[3])
}
else {
if (length(cols) >= 1) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
}
else {
rcol <- (col2rgb("lightblue")/255)[1]
gcol <- (col2rgb("lightblue")/255)[2]
bcol <- (col2rgb("lightblue")/255)[3]
}
}
# main loop: iterate over data points
counter <- 0
for (j in 1:nrow(data)) {
for (k in 1:ncol(data)) {
x <- j/nrow(data) * scale * scalefac
y <- k/ncol(data) * scale * scalefac
z <- data[j, k]
if(ignore_zeros && (z == 0))
next
counter <- counter + 1
# set current color
if (!is.null(ccols)) {
rcol <- (col2rgb(ccols[k])/255)[1]
gcol <- (col2rgb(ccols[k])/255)[2]
bcol <- (col2rgb(ccols[k])/255)[3]
}
else if (!is.null(rcols)) {
rcol <- (col2rgb(rcols[j])/255)[1]
gcol <- (col2rgb(rcols[j])/255)[2]
bcol <- (col2rgb(rcols[j])/255)[3]
}
else {
if(length(rcol) > 1)
{
rcol <- rcol[(k - 1) * ncol(data) +
j]
gcol <- gcol[(k - 1) * ncol(data) +
j]
bcol <- bcol[(k - 1) * ncol(data) +
j]
}
}
# set meta-label touch sensor
if (popuptext) {
popup_txt_str <- paste("Group {\n children [\n DEF Schalter",
(k - 1) * ncol(data) + j - 1, " TouchSensor { }",
sep = "", collapse = "")
popup_txt_str2 <- "\n]\n}"
}
# draw data point
write(paste(popup_txt_str, "Transform {\n\ttranslation ",
origin[1] + x, origin[2] + y, origin[3] + z/2,
"\n\tchildren Shape {\n\t\tappearance Appearance { material Material { diffuseColor ",
rcol, gcol, bcol, " } }\n\tgeometry Box { size ",
blength, bwidth, z, "}\n\t\t}\n}", popup_txt_str2,
sep = " "), file = filename, append = TRUE)
}
}
write("\n", file = filename, append = TRUE)
# configure interactive popup-text
if (popuptext)
write(paste("ROUTE Schalter", 0:(length(metalabels) -
1), ".isOver TO POP.over", 0:(length(metalabels) -
1), "\n", sep = "", collapse = ""), file = filename,
append = TRUE)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY><br>",
file = htmlout, append = FALSE)
cat(paste("<object type=\"x-world/x-vrml\" data=\"",
filename, "\" ", sep = ""), file = htmlout, append = TRUE)
cat(paste("width=\"", hwidth, "\" height=\"", hheight,
"\"><br>", sep = ""), file = htmlout, append = TRUE)
cat(paste("<param name=\"src\" value=\"", filename, "\"><br>",
sep = ""), file = htmlout, append = TRUE)
cat("Your browser cannot display VRML files.<br>Please INSTALL a VRML-plugin or open the file in an external VRML-viewer.</object><br>",
file = htmlout, append = TRUE)
cat("</BODY></HTML>", file = htmlout, append = TRUE)
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# creating scatter plots in VRML-format
`.vcloud` <-
function (x, y = NULL, z = NULL, labels = rownames(data), metalabels = NULL,
hyperlinks = NULL, filename = "out.wrl", pointstyle = c("s",
"b", "c"), cols = rainbow(length(unique(labels))), showdensity = FALSE,
scalefac = 4, autoscale = "independent", lab.axis = c("X-axis",
"Y-axis", "Z-axis"), col.axis = "black", showaxis = TRUE,
col.lab = "black", col.bg = "white", cex.lab = 1, navigation = "EXAMINE",
transparency = 0, fov = 0.785, pos = rep(scalefac + 4, 3),
dir = c(0.19, 0.45, 0.87, 2.45), htmlout = NULL, hwidth = 1200,
hheight = 800, showlegend = TRUE)
{
# extract the coordinate vectors from the input
xyz_parse <- xyz.coords(x, y, z)
data <- cbind(xyz_parse$x, xyz_parse$y, xyz_parse$z)
if (ncol(data) != 3) {
stop("Data matrix does not have 3 columns!")
}
# identify the unique set of row labels
numlabels <- NULL
if (length(labels)) {
lab <- unique(unlist(labels))
numlabels <- apply(as.matrix(labels), 1, function(x) match(x,
as.matrix(lab)))
}
# verify if .vcloud is called within a vrmlgen-environment
# initialized with lg3d.open()
curdir <- NULL
scale <- 1
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write VRML header
write("#VRML V2.0 utf8\n", file = filename, append = FALSE)
write(paste("\nViewpoint {\n\tfieldOfView", fov, "\n\tposition",
pos[1], pos[2], pos[3], "\n\torientation", dir[1],
dir[2], dir[3], dir[4], "\n\tjump TRUE\n\tdescription \"viewpoint1\"\n}\n",
sep = " "), file = filename, append = TRUE)
write(paste("\nNavigationInfo { type \"", navigation,
"\" }\n", sep = ""), file = filename, append = TRUE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}", sep = " "), file = filename,
append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
VRMLDir <- vrmlgenEnv$VRMLDir
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
scale <- vrmlgenEnv$scale
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# apply the chosen scaling method
scaledat <- function(data) {
diff <- max(data) - min(data)
if (diff == 0)
return(data)
else return(scale * scalefac * (data - min(data))/(diff))
}
if (autoscale == "independent")
data <- apply(data, 2, scaledat)
else if (autoscale == "equidist")
data <- scale * scalefac * (data/max(data))
# configure popup-text for metalabels
popuptext <- TRUE
if (is.null(metalabels)) {
popuptext <- FALSE
}
if (popuptext)
write(paste("\n\nPROTO PopupText [\n\teventIn MFString showThis\n\texposedField SFNode fontStyle FontStyle {\n\t\t\t\tjustify [ \"MIDDLE\", \"MIDDLE\" ] }\n\texposedField SFNode appearance Appearance { material Material { } } \n\tfield SFString default \"\" \n\tfield MFString stringlist [ \"\" ] \n",
paste(paste("eventIn SFBool over", 0:(nrow(data) -
1), "\n\t", sep = "", collapse = ""), sep = "",
collapse = ""), "\t] { \nGroup { children [ \n\tDEF POPIT Script { \n\t\tfield SFString defstring IS default \n\t\tfield MFString list IS stringlist \n\t\tfield MFString strout [ \"\" ] ",
paste(paste("\n eventIn SFBool over", 0:(nrow(data) -
1), " IS over", 0:(nrow(data) - 1), sep = "",
collapse = "")), "\n\t\teventOut MFString string_changed \n\t\turl [ \"javascript: \n\t\tfunction evtnum(num, value) \n\t\t{ \n\t\tif (value && (num < list.length)) \n\t\t\tstrout[0] = list[num]; \n\t\telse \n\t\t\tstrout[0] = defstring; \n\t\tstring_changed = strout; \n\t\t} \n \n\t",
paste(paste("\tfunction over", 0:(nrow(data) - 1),
"(v, t) { evtnum(", 0:(nrow(data) - 1), ", v); } \n",
sep = "", collapse = "")), "\t\", \n\t\t\"Popup.class\"] \n\t} \n\t \n\tTransform { \n\ttranslation 0 0 ",
scale * scalefac, " \n\trotation 0.28108 0.67860 0.67860 2.59356\n\t \n\tchildren Shape { \n\t\tappearance IS appearance \n\tgeometry DEF POPUP Text { \n\t\tstring \"\" \n\t\tset_string IS showThis \n\t\tfontStyle IS fontStyle \n\t\t} \n\t} \n\t} \n] } \nROUTE POPIT.string_changed TO POPUP.set_string \n} \n \n \nGroup { \nchildren DEF POP PopupText { \n\t\t#default \"Nothing selected\" \n\t\tstringlist [ ",
paste(paste("\"", metalabels[1:(nrow(data) - 1)],
"\",", sep = "", collapse = " ")), "\"", metalabels[nrow(data)],
"\" ] \n\t} \n} \n\n"), file = filename, append = TRUE)
# draw the plot legend
if (length(labels) && showlegend) {
cur_height <- scale * scalefac + 1.2
for (j in 1:length(unique(labels))) {
.vrmltext(0, 0, cur_height, unique(labels)[j], filename,
cols[unique(numlabels)[j]], 1, c(0.28108, 0.6786,
0.6786, 2.59356), "SANS", "NONE", NULL)
cur_height <- cur_height + 0.4
}
}
# draw the axes
if (showaxis) {
# call the axis3d helper function to draw the axes
axis3d(lab.axis, filename, type = "vrml", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
# initialize color and meta-label variables
popup_txt_str <- ""
popup_txt_str2 <- ""
hyperlink <- NULL
# main loop: iterate over data points
for (j in 1:nrow(data)) {
x <- data[j, 1]
y <- data[j, 2]
z <- data[j, 3]
# apply automatic color selection
colsel <- .colorselection(type = "cloud", j, cols, nrow(data),
labels, numlabels)
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
if (popuptext) {
popup_txt_str <- paste("Group {\n children [\n DEF Schalter",
j - 1, " TouchSensor { }", sep = "", collapse = "")
popup_txt_str2 <- "\n]\n}"
}
if (!is.null(hyperlinks)) {
hyperlink <- hyperlinks[j]
}
# draw data point with given point-style
# and popup-text for meta-labels
if (length(pointstyle) == 1) {
write(popup_txt_str, file = filename, append = TRUE)
# call lower level plotting function to draw datapoints
.vrmlpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle, hyperlinks = hyperlink, global_scale = 1,
local_scale = 1, transparency)
write(popup_txt_str2, file = filename, append = TRUE)
}
else if (length(pointstyle) >= length(unique(numlabels))) {
if (length(labels)) {
stylevec <- c("s", "b", "c")
curstyle <- stylevec[numlabels[j]]
write(popup_txt_str, file = filename, append = TRUE)
.vrmlpoints(x, y, z, filename, rcol, gcol, bcol,
curstyle, hyperlinks = hyperlink, global_scale = 1,
local_scale = 1, transparency)
write(popup_txt_str2, file = filename, append = TRUE)
}
else {
popup_txt_str <- ""
popup_txt_str2 <- ""
write(popup_txt_str, file = filename, append = TRUE)
.vrmlpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle[1], hyperlinks = hyperlink, global_scale = 1,
local_scale = 1, transparency)
write(popup_txt_str2, file = filename, append = TRUE)
}
}
else {
write(popup_txt_str, file = filename, append = TRUE)
.vrmlpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle[1], hyperlinks = hyperlink, global_scale = 1,
local_scale = 1, transparency)
write(popup_txt_str2, file = filename, append = TRUE)
}
}
write("\n", file = filename, append = TRUE)
# configure interactive popup-text
if (popuptext)
write(paste("ROUTE Schalter", 0:(nrow(data) - 1), ".isOver TO POP.over",
0:(nrow(data) - 1), "\n", sep = "", collapse = ""),
file = filename, append = TRUE)
# draw density estimation contour surfaces
if (showdensity)
est <- .vdense(data, filename)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML outputr
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY><br>",
file = htmlout, append = FALSE)
cat(paste("<object type=\"x-world/x-vrml\" data=\"",
filename, "\" ", sep = ""), file = htmlout, append = TRUE)
cat(paste("width=\"", hwidth, "\" height=\"", hheight,
"\"><br>", sep = ""), file = htmlout, append = TRUE)
cat(paste("<param name=\"src\" value=\"", filename, "\"><br>",
sep = ""), file = htmlout, append = TRUE)
cat("Your browser cannot display VRML files.<br>Please INSTALL a VRML-plugin or open the file in an external VRML-viewer.</object><br>",
file = htmlout, append = TRUE)
cat("</BODY></HTML>", file = htmlout, append = TRUE)
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# helper function for density estimation contour surface computation
`.vdense` <-
function (x, filename)
{
nobs <- nrow(x)
ndim <- ncol(x)
weights <- rep(1, nobs)
# compute number of bins (depending on number of observations)
nbins <- round((nobs > 500) * 8 * log(nobs)/ndim)
# compute number of breaks
if (nbins > 0) {
breaks <- cbind(seq(min(x[, 1]), max(x[, 1]), length = nbins +
1), seq(min(x[, 2]), max(x[, 2]), length = nbins +
1))
f1 <- cut(x[, 1], breaks = breaks[, 1])
f2 <- cut(x[, 2], breaks = breaks[, 2])
f3 <- cut(x[, 3], breaks = breaks[, 3])
freq <- table(f1, f2, f3)
dimnames(freq) <- NULL
midpoints <- (breaks[-1, ] + breaks[-(nbins + 1), ])/2
z1 <- midpoints[, 1]
z2 <- midpoints[, 2]
z3 <- midpoints[, 3]
X <- as.matrix(expand.grid(z1, z2, z3))
X.f <- as.vector(freq)
id <- (X.f > 0)
X <- X[id, ]
dimnames(X) <- list(NULL, dimnames(x)[[2]])
X.f <- X.f[id]
bins <- list(x = X, x.freq = X.f, midpoints = midpoints,
breaks = breaks, table.freq = freq)
x <- bins$x
weights <- bins$x.freq
nx <- length(bins$x.freq)
}
else nx <- nobs
h <- .hnorm(x, weights)
rawdata <- list(nbins = nbins, x = x, nobs = nobs, ndim = ndim)
# calculate density estimation contours
est <- .vdensecalc(x, h = h, weights = weights, rawdata = rawdata,
filename = filename)
return(TRUE)
}
# compute density estimation contour surfaces
`.vdensecalc` <-
function (x, h = .hnorm(x, weights), eval.points = NULL, weights = rep(1,
length(x)), rawdata = list(), eval.type = "grid", filename = "test.wrl")
{
# intial settings
xlim <- range(x[, 1])
ylim <- range(x[, 2])
zlim <- range(x[, 3])
ngrid <- 20
if (eval.type != "points") {
evp <- cbind(seq(xlim[1], xlim[2], length = ngrid), seq(ylim[1],
ylim[2], length = ngrid), seq(zlim[1], zlim[2], length = ngrid))
eval.points <- evp
}
h.weights <- rep(1, nrow(x))
n <- nrow(x)
nnew <- nrow(eval.points)
hmult <- 1
# compute density estimation
result <- list(eval.points = eval.points, h = h * hmult,
h.weights = h.weights, weights = weights)
Wh <- matrix(rep(h.weights, nnew), ncol = n, byrow = TRUE)
W1 <- matrix(rep(eval.points[, 1], rep(n, nnew)), ncol = n,
byrow = TRUE)
W1 <- W1 - matrix(rep(x[, 1], nnew), ncol = n, byrow = TRUE)
W1 <- exp(-0.5 * (W1/(hmult * h[1] * Wh))^2)/Wh
W2 <- matrix(rep(eval.points[, 2], rep(n, nnew)), ncol = n,
byrow = TRUE)
W2 <- W2 - matrix(rep(x[, 2], nnew), ncol = n, byrow = TRUE)
W2 <- exp(-0.5 * (W2/(hmult * h[2] * Wh))^2)/Wh
W3 <- matrix(rep(eval.points[, 3], rep(n, nnew)), ncol = n,
byrow = TRUE)
W3 <- W3 - matrix(rep(x[, 3], nnew), ncol = n, byrow = TRUE)
W3 <- exp(-0.5 * (W3/(hmult * h[3] * Wh))^2)/Wh
if (eval.type == "points") {
est <- as.vector(((W1 * W2 * W3) %*% weights)/(sum(weights) *
(2 * pi)^1.5 * h[1] * h[2] * h[3] * hmult^3))
return(est)
}
est <- .vdensecalc(x, h, x, eval.type = "points", weights = weights,
filename = filename)
props <- c(75, 50, 25)
# set colors for different density levels
cols <- topo.colors(length(props))
alpha <- seq(1, 0.5, length = length(props))
levels <- quantile(est, props/100)
est <- apply(W3, 1, function(x) (W1 %*% (weights * x * t(W2)))/(sum(weights) *
(2 * pi)^1.5 * h[1] * h[2] * h[3] * hmult^3))
est <- array(c(est), dim = rep(ngrid, 3))
struct <- NULL
# use misc3d to compute the final contours
if (require(misc3d)) {
struct <- contour3d(est, levels, eval.points[, 1], eval.points[,
2], eval.points[, 3], engine = "none")
} else {
stop("In order to draw contour surfaces, please first install the misc3d package!")
}
# write output to VRML file
for (i in 1:length(props)) {
if (length(props) > 1)
strct <- struct[[i]]
else strct <- struct
trngs.x <- c(t(cbind(strct$v1[, 1], strct$v2[, 1], strct$v3[,
1])))
trngs.y <- c(t(cbind(strct$v1[, 2], strct$v2[, 2], strct$v3[,
2])))
trngs.z <- c(t(cbind(strct$v1[, 3], strct$v2[, 3], strct$v3[,
3])))
a <- list(x = trngs.x, y = trngs.y, z = trngs.z)
rcol <- (col2rgb(cols[i])/255)[1]
gcol <- (col2rgb(cols[i])/255)[2]
bcol <- (col2rgb(cols[i])/255)[3]
# write contours to VRML file
for (j in seq(1, length(trngs.x), 3)) {
write(paste("\n Shape { \n\tappearance Appearance {\n\t\t material Material {\n\t\tdiffuseColor ",
rcol, " ", gcol, " ", bcol, "\n\t\ttransparency ",
alpha[i], " \n\t}\n\t}\t\n \n\t geometry IndexedFaceSet {\n\t \t\tsolid TRUE \t \n\t\tcoord Coordinate {\n\t\t\t point [\n\t\t\t ",
trngs.x[j], trngs.y[j], trngs.z[j], " \n\t\t\t ",
trngs.x[j + 1], trngs.y[j + 1], trngs.z[j + 1],
" \n\t\t\t ", trngs.x[j + 2], trngs.y[j + 2],
trngs.z[j + 2], " \n\t\t ]\n\t }\n\t coordIndex [\t0 1 2\t] \n\t}\t \n }\n ",
sep = " "), file = filename, append = TRUE)
}
}
return(est)
}
# helper function for density estimation contour surface computation
`.hnorm` <-
function (x, weights = NA)
{
if (all(is.na(weights)))
weights <- rep(1, nrow(x))
ndim <- ncol(as.matrix(x))
if (ndim != 3)
stop("only data with 3 dimensions is allowed.")
n <- sum(weights)
sd <- sqrt(apply(x, 2, function(x, w) {
sum(w * (x - sum(x * w)/sum(w))^2)/(sum(w) - 1)
}, w = weights))
hh <- sd * (4/(5 * n))^(1/7)
hh
}
# creating 3D-meshes in VRML-format
`.vmesh` <-
function (infile = NULL, x = NULL, y = NULL, z = NULL, edges = NULL,
xfun = "sin(v)*cos(u)", yfun = "sin(v)*sin(u)", zfun = "cos(v)",
param1 = "u", param2 = "v", range1 = c(0, 2 * pi), range2 = c(0,
pi), size1 = 30, size2 = 30, write_obj = FALSE, filename = "out.wrl",
cols = "red", scalefac = 4, autoscale = ifelse(is.null(infile),
"independent", "equicenter"), lab.axis = c("X-axis",
"Y-axis", "Z-axis"), col.axis = "black", showaxis = TRUE,
col.lab = "black", col.bg = "white", cex.lab = 1, navigation = "EXAMINE",
transparency = 0, fov = 0.785, pos = rep(scalefac + 4, 3),
dir = c(0.19, 0.45, 0.87, 2.45), htmlout = NULL, hwidth = 1200,
hheight = 800)
{
# write output in obj-format, if write_obj == TRUE and vertex-
# and edge-data is available
if (write_obj) {
if (is.null(x) && is.null(edges)) {
stop("\nThe generation of obj-files is currently only supported, when using vertex-coordinates (x, y, z-parameters) and polygonal face indices (edges-parameter) as input.")
}
# write OBJ header
write("# OBJ file created by VRMLgen\n#\n", file = filename,
append = FALSE)
# extract coordinate vectors from input
xyz_parse <- xyz.coords(x, y, z)
# generate the OBJ output file
write(paste("v", xyz_parse$x, xyz_parse$y, xyz_parse$z,
sep = " "), file = filename, append = TRUE)
write("\n", file = filename, append = TRUE)
for (i in 1:nrow(edges)) {
write(paste("f", paste(edges[i, ], collapse = " "),
sep = " "), file = filename, append = TRUE)
}
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
# check which input is supplied:
else {
# case 1: the user provides an obj-file as input
if (!is.null(infile)) {
# read the obj-file
obj <- strsplit(readLines(infile), "\t")
# collect face data
faces <- which(as.numeric(lapply(obj, function(x) grep("^f",
x[1]))) == 1)
# collect node data
nodes <- which(as.numeric(lapply(obj, function(x) grep("^v ",
x[1]))) == 1)
# parse node data
tmpmat <- lapply(obj[nodes], function(x) strsplit(x,
" ")[[1]])
# extract edges from faces
redmat <- t(sapply(tmpmat, function(x) as.numeric(x[2:length(x)])))
data <- redmat[, which(apply(redmat, 2, function(x) !any(is.na(x))))]
edges_lst <- lapply(obj[faces], function(x) strsplit(x,
" ")[[1]])
edges_filt1 <- lapply(edges_lst, function(y) as.numeric(sapply(y[2:length(y)],
function(x) strsplit(x, "/")[[1]][1])))
edges_filt <- lapply(edges_filt1, function(x) x[which(!is.na(x))])
# split faces with more than 4 edges into smaller faces
filter <- sapply(edges_filt, length) > 4
filt <- edges_filt[filter]
reduced_lst <- NULL
if (length(filt) > 0) {
for (j in 1:length(filt)) {
reduced_lst <- c(reduced_lst, list(filt[[j]][1:4]))
for (k in seq(4, length(filt[[j]]), 3)) {
if (!is.na(filt[[j]][k + 2])) {
reduced_lst <- c(reduced_lst, list(c(filt[[j]][k:(k +
2)], filt[[j]][1])))
}
else if (!is.na(filt[[j]][k + 1])) {
reduced_lst <- c(reduced_lst, list(c(filt[[j]][k:(k +
1)], filt[[j]][1], 0)))
break
}
else {
break
}
}
}
}
# combine edge data
comb_lst <- c(edges_filt[!filter], reduced_lst)
filtless <- which(sapply(comb_lst, length) < 4)
comb_lst[filtless] <- lapply(comb_lst[filtless],
function(x) c(x, 0))
all(sapply(comb_lst, length) == 4)
edges <- t(sapply(comb_lst, rbind)) - 1
}
# case 2: a parametric function is used as input
else if (is.null(x)) {
# check if the required data is available
if (is.null(xfun) || is.null(yfun) || is.null(zfun)) {
stop("Either the paramater infile or data or the parameters xfun, yfun and zfun have to be specified.")
}
if (is.null(param1) || is.null(param2)) {
stop("The parameter names param1 and param2 have not been specified")
}
# initialize variables
x <- NULL
y <- NULL
z <- NULL
smin <- range1[1]
smax <- range1[2]
tmin <- range2[1]
tmax <- range2[2]
sn <- size1
tn <- size2
ds <- (smax - smin)/sn
dt <- (tmax - tmin)/tn
# compute the data points representing the parametric function
for (i in seq(smin, (smax - ds/2), ds)) {
for (j in seq(tmin, (tmax - dt/2), dt)) {
eval(parse(text = paste(param1, " <- ", i)))
eval(parse(text = paste(param2, " <- ", j)))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param1, " <- ", param1,
" + ds")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param2, " <- ", param2,
" + dt")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param1, " <- ", param1,
" - ds")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
}
}
# combine data
data <- as.matrix(cbind(x, y, z))
}
else {
# mesh vertex data is directly provided as input
xyz_parse <- xyz.coords(x, y, z)
data <- cbind(xyz_parse$x, xyz_parse$y, xyz_parse$z)
}
if (ncol(data) != 3) {
stop("Data matrix does not have 3 columns!")
}
# verify if .lbar is called within a vrmlgen-environment
# initialized with vrml.open()
scale <- 1
curdir <- NULL
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write VRML header
write("#VRML V2.0 utf8\n", file = filename, append = FALSE)
write(paste("\nViewpoint {\n\tfieldOfView", fov,
"\n\tposition", pos[1], pos[2], pos[3], "\n\torientation",
dir[1], dir[2], dir[3], dir[4], "\n\tjump TRUE\n\tdescription \"viewpoint1\"\n}\n",
sep = " "), file = filename, append = TRUE)
write(paste("\nNavigationInfo { type \"", navigation,
"\" }\n", sep = ""), file = filename, append = TRUE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ",
bg_rcol, bg_gcol, bg_bcol, " \n\t]\n}", sep = " "),
file = filename, append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
scale <- vrmlgenEnv$scale
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# apply the chosen scaling method
scaledat <- function(data) {
diff <- max(data) - min(data)
if (diff == 0)
return(data)
else return(scale * scalefac * (data - min(data))/(diff))
}
if (autoscale == "independent")
data <- apply(data, 2, scaledat)
else if (autoscale == "equidist")
data <- scale * scalefac * (data/max(data))
else if (autoscale == "equicenter")
data <- scale * scalefac/2 * data/max(data) + scalefac/2
# draw the axes
if (showaxis) {
# call the axis3d helper function to draw the axes
axis3d(lab.axis, filename, type = "vrml", col.lab,
col.axis, cex.lab, local_scale = scalefac, global_scale = 1)
}
# write the data point coordinates
write(paste("Transform {\nscale 1.0 1.0 1.0\n\tchildren [\n\t\tShape {\n\t\t\tappearance Appearance{ material Material{ transparency ",transparency,"}}\n",
sep = " "), file = filename, append = TRUE)
write(paste("\n\t\t\tgeometry IndexedFaceSet {\n\t\t\tcoord DEF\n\tVertexArray Coordinate{\n\tpoint [\n",
sep = " "), file = filename, append = TRUE)
for (j in 1:nrow(data)) {
write(paste(paste(data[j, ], collapse = " "), ",\n",
sep = ""), file = filename, append = TRUE)
}
write("]\n}\n", file = filename, append = TRUE)
# write the edges (using coordinate indices)
write("coordIndex [\n", file = filename, append = TRUE)
mat <- NULL
if (!is.null(edges)) {
mat <- edges
while (ncol(mat) < 4) {
mat <- cbind(mat, rep(-1, nrow(mat)))
}
}
else {
mat <- matrix(1:nrow(data), ncol = 4, byrow = TRUE) -
1
}
for (j in 1:nrow(mat)) {
write(paste(paste(mat[j, ], collapse = " "), "-1",
sep = " "), file = filename, append = TRUE)
}
# write vertex colors
write(paste("]\n solid FALSE\n colorPerVertex TRUE\n color \nDEF VertexColorArray Color{\ncolor [",
sep = ""), file = filename, append = TRUE)
# use rainbow colors if no colors are pre-defined
if (!length(cols) || (is.null(cols))) {
cols <- rainbow(nrow(data))
mat <- sapply(cols, function(x) (col2rgb(x)/255))
for (j in 1:nrow(data)) {
write(paste(mat[1, j], mat[2, j], mat[3, j],
",\n", collapse = " "), file = filename, append = TRUE)
}
}
# use a single color if the number of colors is less than the number of data rows
else if ((length(cols) == 1) || (length(cols) < nrow(data))) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
for (j in 1:nrow(data)) {
write(paste(rcol, gcol, bcol, ",\n", collapse = " "),
file = filename, append = TRUE)
}
}
else {
mat <- sapply(cols, function(x) (col2rgb(x)/255))
for (j in 1:nrow(data)) {
write(paste(mat[1, j], mat[2, j], mat[3, j],
",\n", collapse = " "), file = filename, append = TRUE)
}
}
write(paste("]\n}\n}\n}\n]\n}", sep = ""), file = filename,
append = TRUE)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY><br>",
file = htmlout, append = FALSE)
cat(paste("<object type=\"x-world/x-vrml\" data=\"",
filename, "\" ", sep = ""), file = htmlout,
append = TRUE)
cat(paste("width=\"", hwidth, "\" height=\"",
hheight, "\"><br>", sep = ""), file = htmlout,
append = TRUE)
cat(paste("<param name=\"src\" value=\"", filename,
"\"><br>", sep = ""), file = htmlout, append = TRUE)
cat("Your browser cannot display VRML files.<br>Please INSTALL a VRML-plugin or open the file in an external VRML-viewer.</object><br>",
file = htmlout, append = TRUE)
cat("</BODY></HTML>", file = htmlout, append = TRUE)
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
}
# lower-level function for plotting data points in the VRML-format
`.vrmlpoints` <-
function (x, y, z, filename, rcol, gcol, bcol, pointstyle, hyperlinks = NULL,
global_scale = 1, local_scale = 1, transparency = 0)
{
# add hyperlinks to the data points
hyperlinks_start <- rep("", length(x))
hyperlinks_end <- rep("", length(x))
if (!is.null(hyperlinks)) {
hyperlinks_start <- paste("\n\tchildren Anchor { url \"",
hyperlinks, "\"", sep = "")
hyperlinks_end <- rep("}", length(x))
}
# check the point-style and draw the data points at the
# corresponding coordinates
if (pointstyle == "s") {
for (i in 1:length(x))
write(paste("\nTransform {\n\ttranslation ",
x[i] * global_scale, y[i] * global_scale, z[i] *
global_scale, hyperlinks_start[i], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material { diffuseColor",
rcol, gcol, bcol, "transparency", transparency, "} }\n\tgeometry Sphere { radius ",
0.08 * local_scale, "}\n\t\t}", hyperlinks_end[i],
"\n}", sep = " "), file = filename, append = TRUE)
}
else if (pointstyle == "c") {
for (i in 1:length(x))
write(paste("\nTransform {\n\trotation 1 0 0 1.5708\n\ttranslation ",
x[i] * global_scale, y[i] * global_scale, z[i] *
global_scale, hyperlinks_start[i], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material { diffuseColor",
rcol, gcol, bcol, "transparency", transparency, "} }\n\tgeometry Cone { bottomRadius ",
0.08 * local_scale, "height", 0.08 * local_scale,
"\n\t\tside TRUE}\n\t\t}", hyperlinks_end[i], "\n}",
sep = " "), file = filename, append = TRUE)
}
else {
for (i in 1:length(x))
write(paste("\nTransform {\n\ttranslation ",
x[i] * global_scale, y[i] * global_scale, z[i] *
global_scale, hyperlinks_start[i], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material { diffuseColor",
rcol, gcol, bcol, "transparency", transparency, "} }\n\tgeometry Box { size ",
0.08 * local_scale, 0.08 * local_scale, 0.08 * local_scale,
"}\n\t\t}", hyperlinks_end[i], "\n}", sep = " "),
file = filename, append = TRUE)
}
}
# lower-level function for adding text to a 3D-scene
# in the Livegraphics3D-format
`.vrmltext` <-
function (x, y, z, text, filename, col, scale, rot, fontfamily,
fontweight, hyperlink)
{
# convert the color to RGB-format
rcol <- (col2rgb(col)/255)[1]
gcol <- (col2rgb(col)/255)[2]
bcol <- (col2rgb(col)/255)[3]
# add hyperlinks to the text
if (is.null(hyperlink)) {
for (i in 1:length(x))
write(paste("Transform {\n\ttranslation ",
x[i], y[i], z[i], "\n\tscale ", 0.28, 0.28, 0.28,
"\n\trotation ", rot[1], rot[2], rot[3], rot[4],
"\n\tchildren Shape {\n\t\tappearance Appearance { material Material {diffuseColor ",
rcol, gcol, bcol, " } }\n\tgeometry Text { string \"",
text[i], "\"\nfontStyle FontStyle {\nsize ", scale,
"\nfamily [\"", fontfamily, "\"]\njustify \"MIDDLE\"\n style \"",
fontweight, "\" }\n }\n\t}\n}", sep = " "), file = filename,
append = TRUE)
}
else {
for (i in 1:length(x))
write(paste("Transform {\n\ttranslation ",
x[i], y[i], z[i], "\n\tscale ", 0.28, 0.28, 0.28,
"\n\trotation ", rot[1], rot[2], rot[3], rot[4],
"\n\tchildren Anchor { url \"", hyperlink, "\" \n\tchildren Shape {\n\t\tappearance Appearance { material Material {diffuseColor ",
rcol, gcol, bcol, " } }\n\tgeometry Text { string \"",
text[i], "\"\nfontStyle FontStyle {\nsize ", scale,
"\nfamily [\"SANS\"]\njustify \"MIDDLE\"\n style \"",
fontweight, "\" }\n }\n\t}\n}\n}", sep = " "), file = filename,
append = TRUE)
}
}
Try the vrmlgen package in your browser
Any scripts or data that you put into this service are public.
vrmlgen documentation built on May 2, 2019, 1:06 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.
# helper function to apply the automatic coloring of
# labeled datapoints in different plotting functions
`.colorselection` <-
function (type = "cloud", index, cols, numpoints, labels, numlabels)
{
# automatic coloring for bar plot functions
if (type == "bar") {
if (length(cols) == length(labels)) {
rcol <- (col2rgb(cols[index])/255)[1]
gcol <- (col2rgb(cols[index])/255)[2]
bcol <- (col2rgb(cols[index])/255)[3]
}
else if (length(cols) == 1) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
}
else {
rcol <- (col2rgb("black")/255)[1]
gcol <- (col2rgb("black")/255)[2]
bcol <- (col2rgb("black")/255)[3]
}
}
# automatic coloring for 3D cloud and mesh plots
else {
if (!length(cols)) {
rcol <- (col2rgb(rainbow(numpoints)[index])/255)[1]
gcol <- (col2rgb(rainbow(numpoints)[index])/255)[2]
bcol <- (col2rgb(rainbow(numpoints)[index])/255)[3]
}
else if ((length(cols) == 1) || ((length(cols) < numpoints) &&
!length(labels))) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
}
else if (length(labels) && (length(cols) == length(unique(labels))) &&
(type != "mesh")) {
rcol <- (col2rgb(cols[numlabels[index]])/255)[1]
gcol <- (col2rgb(cols[numlabels[index]])/255)[2]
bcol <- (col2rgb(cols[numlabels[index]])/255)[3]
}
else {
rcol <- (col2rgb(cols[index])/255)[1]
gcol <- (col2rgb(cols[index])/255)[2]
bcol <- (col2rgb(cols[index])/255)[3]
}
}
return(list(rcol = rcol, gcol = gcol, bcol = bcol))
}
# creating bar plots in Livegraphics3D-format
`.lbar` <-
function (data, row.labels = rownames(data), col.labels = colnames(data),
filename = "out.m", space = 0.5, cols = rainbow(length(as.matrix(data))),
rcols = NULL, ccols = NULL, origin = c(0, 0, 0), scalefac = 4, autoscale = TRUE,
ignore_zeros = TRUE, lab.axis = c("X-axis", "Y-axis", "Z-axis"), col.axis = "black",
showaxis = TRUE, col.lab = "black", col.bg = "white", cex.lab = 1,
cex.rowlab = 1, cex.collab = 1, ambientlight = 0.5, htmlout = NULL,
hwidth = 1200, hheight = 800, showlegend = TRUE)
{
data <- as.matrix(data)
curdir <- NULL
# verify if .lbar is called within a vrmlgen-environment
# initialized with lg3d.open()
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write LiveGraphics3D header
write("Graphics3D[\n{\n", file = filename, append = FALSE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}", sep = " "), file = filename,
append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# scale the data to fit within the axes ranges
if(autoscale)
data <- scalefac * (data/max(data))
# pre-process row- and column-labels
if (!is.null(col.labels) && showlegend)
col.labels <- sapply(strsplit(col.labels, " "), function(x) paste(x,
collapse = "\n"))
if (!is.null(row.labels) && showlegend)
row.labels <- sapply(strsplit(row.labels, " "), function(x) paste(x,
collapse = "\n"))
# calculate bar-length and -width (account for scaling and spacing)
blength <- scalefac/(nrow(data) * (1 + space))
bwidth <- scalefac/(ncol(data) * (1 + space))
# draw the axes
if (showaxis) {
# call the axis3d helper function to draw the axes
axis3d(lab.axis, filename, type = "lg3d", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
# draw row-labels
if (!is.null(row.labels) && showlegend) {
for (j in 1:length(row.labels)) {
# apply automatic color selection
colsel <- .colorselection(type = "bar", j, rcols,
1, row.labels, "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
cur_xwidth <- j/nrow(data) * scalefac - blength/2
write(paste("RGBColor[", rcol, ",", gcol, ",", bcol,
"], Text [ \"", row.labels[j], "\", {", cur_xwidth,
",", -0.4, ",", scalefac + 0.2, "}],\n", sep = ""),
file = filename, append = TRUE)
}
}
# draw column-labels
if (!is.null(col.labels) && showlegend) {
for (j in 1:length(col.labels)) {
# apply automatic color selection
colsel <- .colorselection(type = "bar", j, ccols,
1, col.labels, "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
cur_ywidth <- j/ncol(data) * scalefac - bwidth/2
write(paste("RGBColor[", rcol, ",", gcol, ",", bcol,
"], Text [ \"", col.labels[j], "\", {", -0.4,
",", cur_ywidth, ",", scalefac + 0.2, "}],\n",
sep = ""), file = filename, append = TRUE)
}
}
rcol <- NULL
gcol <- NULL
bcol <- NULL
# set RGB-colors
if (length(cols) >= (ncol(data) * nrow(data))) {
rcol <- sapply(cols, function(x) (col2rgb(x)/255)[1])
gcol <- sapply(cols, function(x) (col2rgb(x)/255)[2])
bcol <- sapply(cols, function(x) (col2rgb(x)/255)[3])
}
else {
if (length(cols) >= 1) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
}
else {
rcol <- (col2rgb("lightblue")/255)[1]
gcol <- (col2rgb("lightblue")/255)[2]
bcol <- (col2rgb("lightblue")/255)[3]
}
}
# main loop: iterate over data points
bwidth <- bwidth/2
for (k in 1:ncol(data)) {
for (j in 1:nrow(data)) {
x <- j/nrow(data) * scalefac
y <- k/ncol(data) * scalefac
z <- data[j, k]
if(ignore_zeros && (z == 0))
next
# set current color
if (!is.null(ccols)) {
rcol <- (col2rgb(ccols[k])/255)[1]
gcol <- (col2rgb(ccols[k])/255)[2]
bcol <- (col2rgb(ccols[k])/255)[3]
}
else if (!is.null(rcols)) {
rcol <- (col2rgb(rcols[j])/255)[1]
gcol <- (col2rgb(rcols[j])/255)[2]
bcol <- (col2rgb(rcols[j])/255)[3]
}
else {
if(length(rcol) > 1)
{
rcol <- rcol[(k - 1) * ncol(data) +
j]
gcol <- gcol[(k - 1) * ncol(data) +
j]
bcol <- bcol[(k - 1) * ncol(data) +
j]
}
}
# draw data point
write(paste("SurfaceColor[RGBColor[", rcol, ",",
gcol, ",", bcol, "]], Cuboid[{", origin[1] +
x - bwidth, ",", origin[2] + y - bwidth, ",",
origin[3], "},{", origin[1] + x + bwidth, ",",
origin[2] + y + bwidth, ",", origin[3] + z, "}],",
sep = ""), file = filename, append = TRUE)
}
}
# configure general plot settings (font size, text style, etc.)
write(paste("\n}, Boxed -> False, Axes -> False, AmbientLight->GrayLevel[",
ambientlight, "], TextStyle -> {FontFamily -> \"TimesRoman\", FontSlant ->\"Italic\", FontSize -> ",
14 * cex.lab, "}, Lighting -> True, BoxRatios -> Automatic, PlotRange -> All ]\n",
sep = ""), file = filename, append = TRUE)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY>",
file = htmlout, append = TRUE)
cat(paste("<APPLET ARCHIVE=\"live.jar\" CODE=\"Live.class\" WIDTH=",
hwidth, " HEIGHT=", hheight, " ALIGN=LEFT>",
sep = ""), file = htmlout, append = TRUE)
coln <- col2rgb(col.bg)
cat(paste("<PARAM NAME=\"BGCOLOR\" VALUE=\"", rgb(red = coln[1,
]/255, green = coln[2, ]/255, blue = coln[3,
]/255), "\">", sep = ""), file = htmlout, append = TRUE)
cat("<PARAM NAME=\"MAGNIFICATION\" VALUE=1.0>", file = htmlout,
append = TRUE)
cat(paste("<PARAM NAME=\"INPUT_FILE\" VALUE=\"",
filename, "\">", sep = ""), file = htmlout, append = TRUE)
cat("</APPLET>", file = htmlout, append = TRUE)
cat("</HTML>", file = htmlout, append = TRUE)
}
# copy the Livegraphics3D live.jar to the output directory
datadir <- system.file("extdata", package = "vrmlgen")
curdir <- getwd()
# use if file.exists
if (data.class(result<-try(file.copy(file.path(datadir, "live.jar"), file.path(curdir, "live.jar")), TRUE))=="try-error")
{
warning("\nCannot copy file live.jar from vrlmgen-folder to current directory. You might need to copy the file manually.")
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# creating scatter plots in Livegraphics3D-format
`.lcloud` <-
function (x, y = NULL, z = NULL, labels = rownames(data), metalabels = NULL,
hyperlinks = NULL, filename = "out.m", pointstyle = c("s",
"b", "t"), cols = rainbow(length(unique(labels))), scalefac = 4,
autoscale = "independent", lab.axis = c("X-axis", "Y-axis",
"Z-axis"), col.axis = "black", showaxis = TRUE, col.lab = "black",
col.metalab = "black", col.bg = "white", cex.lab = 1, ambientlight = 0.5,
htmlout = NULL, hwidth = 1200, hheight = 800, showlegend = TRUE)
{
# extract the coordinate vectors from the input
xyz_parse <- xyz.coords(x, y, z)
data <- cbind(xyz_parse$x, xyz_parse$y, xyz_parse$z)
if (ncol(data) != 3) {
stop("Data matrix does not have 3 columns!")
}
# identify the unique set of row labels
numlabels <- NULL
if (length(labels)) {
lab <- unique(unlist(labels))
numlabels <- apply(as.matrix(labels), 1, function(x) match(x,
as.matrix(lab)))
}
# verify if .lcloud is called within a vrmlgen-environment
# initialized with lg3d.open()
curdir <- NULL
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
write("Graphics3D[\n{\n", file = filename, append = FALSE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}, \n", sep = " "), file = filename,
append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# apply the chosen scaling method
scaledat <- function(data) {
diff <- max(data) - min(data)
if (diff == 0)
return(data)
else return(scalefac * (data - min(data))/(diff))
}
if (autoscale == "independent")
data <- apply(data, 2, scaledat)
else if (autoscale == "equidist")
data <- scalefac * (data/max(data))
# create the plot legend
if (length(labels) && showlegend) {
cur_height <- scalefac + 1 + cex.lab/5
for (j in 1:length(unique(labels))) {
# write text using the lower-level text
# drawing function
.lg3dtext(0, 0, cur_height, unique(labels)[j], filename,
cols[unique(numlabels)[j]], 1, "Arial", "Plain",
NULL)
cur_height <- cur_height + 0.4
}
}
# draw the axes
lab_rcol <- NULL
lab_gcol <- NULL
lab_bcol <- NULL
ax_rcol <- NULL
ax_gcol <- NULL
ax_bcol <- NULL
if (showaxis) {
# call the axis3d helper function to draw the axes
axis3d(lab.axis, filename, type = "lg3d", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
# use empty metalabels if only url-labels have been defined
if ((length(metalabels) == 0) && (length(hyperlinks) >= 1)) {
metalabels <- rep(" ", length(hyperlinks))
}
# main loop: iterate over data points
for (j in 1:nrow(data)) {
x <- data[j, 1]
y <- data[j, 2]
z <- data[j, 3]
# apply automatic color selection
colsel <- .colorselection(type = "cloud", j, cols, nrow(data),
labels, numlabels)
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
# draw data points with given point-style
if (length(pointstyle) == 1) {
.lg3dpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle, hyperlinks = NULL, local_scale = 1)
}
else if (length(pointstyle) >= length(unique(numlabels))) {
if (length(labels)) {
stylevec <- c("s", "b", "t")
curstyle <- stylevec[numlabels[j]]
.lg3dpoints(x, y, z, filename, rcol, gcol, bcol,
curstyle, hyperlinks = NULL, local_scale = 1)
}
else {
.lg3dpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle[1], hyperlinks = NULL, local_scale = 1)
}
}
else {
.lg3dpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle[1], hyperlinks = NULL, local_scale = 1)
}
if (length(metalabels) >= j) {
frcol <- (col2rgb(col.metalab)/255)[1]
fgcol <- (col2rgb(col.metalab)/255)[2]
fbcol <- (col2rgb(col.metalab)/255)[3]
# add metalabels and hyperlinks
write(paste("Text[StyleForm[\"", metalabels[j], "\",FontFamily -> \"Arial\", FontWeight->\"Bold\", FontColor -> RGBColor[",
frcol, ",", fgcol, ",", fbcol, "], FontSize->9,",
sep = ""), file = filename, append = TRUE)
if (length(hyperlinks) >= j) {
write(paste("URL -> \"", hyperlinks[j], ",target=_blank\",",
sep = ""), file = filename, append = TRUE)
}
write(paste("],{", x, ",", y, ",", z, "}],", sep = ""),
file = filename, append = TRUE)
}
}
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
write(paste("\n}, Boxed -> False, Axes -> False, AmbientLight->GrayLevel[",
ambientlight, "], TextStyle -> {FontFamily -> \"TimesRoman\", FontSlant ->\"Italic\", FontSize -> ",
14 * cex.lab, "}, Lighting -> True, BoxRatios -> Automatic, PlotRange -> All ]\n",
sep = ""), file = filename, append = TRUE)
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY>",
file = htmlout, append = TRUE)
cat(paste("<APPLET ARCHIVE=\"live.jar\" CODE=\"Live.class\" WIDTH=",
hwidth, " HEIGHT=", hheight, " ALIGN=LEFT>",
sep = ""), file = htmlout, append = TRUE)
coln <- col2rgb(col.bg)
cat(paste("<PARAM NAME=\"BGCOLOR\" VALUE=\"", rgb(red = coln[1,
]/255, green = coln[2, ]/255, blue = coln[3,
]/255), "\">", sep = ""), file = htmlout, append = TRUE)
cat("<PARAM NAME=\"MAGNIFICATION\" VALUE=1.0>", file = htmlout,
append = TRUE)
cat(paste("<PARAM NAME=\"INPUT_FILE\" VALUE=\"",
filename, "\">", sep = ""), file = htmlout, append = TRUE)
cat("</APPLET></BODY>", file = htmlout, append = TRUE)
cat("</HTML>", file = htmlout, append = TRUE)
}
# copy the Livegraphics3D live.jar to the output directory
datadir <- system.file("extdata", package = "vrmlgen")
curdir <- getwd()
if (data.class(result<-try(file.copy(file.path(datadir, "live.jar"), file.path(curdir, "live.jar")), TRUE))=="try-error")
{
warning("\nCannot copy file live.jar from vrlmgen-folder to current directory. You might need to copy the file manually.")
}
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# lower-level function for plotting data points in the Livegraphics3D-format
`.lg3dpoints` <-
function (x, y, z, filename, rcol, gcol, bcol, pointstyle, hyperlinks = NULL,
global_scale = 1, local_scale = 1)
{
# check the point-style and draw the data points at the
# corresponding coordinates
if (pointstyle == "s") {
for (i in 1:length(x))
write(paste("PointSize[", 0.02 *
local_scale, "], RGBColor[", rcol, ",",
gcol, ",", bcol, "], Point[{", x[i],
",", y[i], ",", z[i],
"}],", sep = ""), file = filename, append = TRUE)
}
else if (pointstyle == "t") {
for (i in 1:length(x))
write(paste("{ SurfaceColor[RGBColor[",
rcol, ",", gcol, ",", bcol, "]], Polygon[{{", local_scale *
x[i], ", ", local_scale * y[i], ",", local_scale *
(z[i] + 0.06415), "}, {", local_scale * global_scale *
(x[i] + 0.09072222), ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] -
0.096225), "}, {", local_scale * global_scale *
x[i] - 0.09072222, ",", local_scale * global_scale *
y[i] + 0.15713333, ",", local_scale * global_scale *
z[i] - 0.096225, "}}], Polygon[{{", local_scale *
global_scale * x[i], ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] +
0.06415), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] + 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] - 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}}], Polygon[{{", local_scale *
global_scale * x[i], ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] +
0.06415), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] - 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}, {", local_scale * global_scale *
(x[i] + 0.09072222), ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] -
0.096225), "}}], Polygon[{{", local_scale * global_scale *
(x[i] + 0.09072222), ",", local_scale * global_scale *
y[i], ",", local_scale * global_scale * (z[i] -
0.096225), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] - 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}, {", local_scale * global_scale *
(x[i] - 0.09072222), ",", local_scale * global_scale *
(y[i] + 0.15713333), ",", local_scale * global_scale *
(z[i] - 0.096225), "}}] },\n", sep = ""), file = filename,
append = TRUE)
}
else {
for (i in 1:length(x))
write(paste("SurfaceColor[RGBColor[",
rcol, ",", gcol, ",", bcol, "]], Cuboid[{", local_scale *
(x[i] - 0.04), ",", local_scale * (y[i] - 0.04),
",", local_scale * (z[i] - 0.04), "},{", local_scale *
global_scale * (x[i] + 0.04), ",", local_scale *
global_scale * (y[i] + 0.04), ",", local_scale *
global_scale * (z[i] + 0.04), "}],", sep = ""),
file = filename, append = TRUE)
}
# add hyperlinks to the datapoints
if (!is.null(hyperlinks)) {
for (i in 1:length(hyperlinks))
write(paste("Text[StyleForm[\" \", URL -> \"",
hyperlinks, "\"], {", local_scale * x[i], ",", local_scale *
y[i], ",", local_scale * z[i], "}],", sep = ""),
file = filename, append = TRUE)
}
}
# lower-level function for adding text to a 3D-scene
# in the Livegraphics3D-format
`.lg3dtext` <-
function (x, y, z, text, filename, col, scale, fontfamily, fontweight,
hyperlink)
{
# convert the color to RGB-format
rcol <- (col2rgb(col)/255)[1]
gcol <- (col2rgb(col)/255)[2]
bcol <- (col2rgb(col)/255)[3]
# add hyperlinks to the text
if (is.null(hyperlink)) {
for (i in 1:length(x))
write(paste("RGBColor[", rcol,
",", gcol, ",", bcol, "], Text [StyleForm[\"", text[i],
"\", FontFamily -> \"", fontfamily, "\", FontSize-> ",
14 * scale, ", FontWeight->\"", fontweight, "\"], {",
x[i], ",", y[i], ",", z[i], "}],\n", sep = ""), file = filename,
append = TRUE)
}
else {
for (i in 1:length(x))
write(paste("RGBColor[", rcol,
",", gcol, ",", bcol, "], Text [StyleForm[\"", text[i],
"\", FontFamily -> \"", fontfamily, "\", FontSize-> ",
14 * scale, ", URL -> \"", hyperlink, "\", FontWeight->\"",
fontweight, "\"], {", x[i], ",", y[i], ",", z[i],
"}],\n", sep = ""), file = filename, append = TRUE)
}
}
# creating 3D-meshes in Livegraphics3D-format
`.lmesh` <-
function (xfun = "sin(v)*cos(u)", yfun = "sin(v)*sin(u)", zfun = "cos(v)",
param1 = "u", param2 = "v", range1 = c(0, 2 * pi), range2 = c(0,
pi), size1 = 30, size2 = 30, filename = "out.m", cols = "red",
scalefac = 4, autoscale = "independent", lab.axis = c("X-axis",
"Y-axis", "Z-axis"), col.axis = "black", showaxis = TRUE,
col.lab = "black", col.bg = "white", cex.lab = 1, ambientlight = 0.5,
htmlout = NULL, hwidth = 1200, hheight = 800)
{
# check if the required input data is available
if (is.null(xfun) || is.null(yfun) || is.null(zfun)) {
stop("Either the paramater infile or data or the parameters xfun, yfun and zfun have to be specified.")
}
if (is.null(param1) || is.null(param2)) {
stop("The parameter names param1 and param2 have not been specified")
}
# initialize variables
x <- NULL
y <- NULL
z <- NULL
smin <- range1[1]
smax <- range1[2]
tmin <- range2[1]
tmax <- range2[2]
sn <- size1
tn <- size2
ds <- (smax - smin)/sn
dt <- (tmax - tmin)/tn
# compute the data points representing the parametric function
for (i in seq(smin, (smax - ds/2), ds)) {
for (j in seq(tmin, (tmax - dt/2), dt)) {
eval(parse(text = paste(param1, " <- ", i)))
eval(parse(text = paste(param2, " <- ", j)))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param1, " <- ", param1, " + ds")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param2, " <- ", param2, " + dt")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param1, " <- ", param1, " - ds")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
}
}
# combine data
data <- as.matrix(cbind(x, y, z))
if (ncol(data) != 3) {
stop("Data matrix does not have 3 columns!")
}
# verify if .lmesh is called within a vrmlgen-environment
# initialized with lg3d.open()
curdir <- NULL
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write LiveGraphics3D header
write("Graphics3D[\n{\n", file = filename, append = FALSE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}", sep = " "), file = filename,
append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# apply the chosen scaling method
scaledat <- function(data) {
diff <- max(data) - min(data)
if (diff == 0)
return(data)
else return(scalefac * (data - min(data))/(diff))
}
if (autoscale == "independent")
data <- apply(data, 2, scaledat)
else if (autoscale == "equidist")
data <- scalefac * (data/max(data))
else if (autoscale == "equicenter")
data <- scalefac/2 * data/max(data) + scalefac/2
lab_rcol <- NULL
lab_gcol <- NULL
lab_bcol <- NULL
ax_rcol <- NULL
ax_gcol <- NULL
ax_bcol <- NULL
# draw the axes
if (showaxis) {
axis3d(lab.axis, filename, type = "lg3d", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
for (j in 1:nrow(data)) {
x <- data[j, 1]
y <- data[j, 2]
z <- data[j, 3]
# apply automatic color selection
colsel <- .colorselection(type = "mesh", j, cols, nrow(data),"", "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
if (j%%4 == 1)
write(paste(" SurfaceColor[RGBColor[", rcol, ",",
gcol, ",", bcol, "]], Polygon[{{", x, ",", y,
",", z, "},", sep = ""), file = filename, append = TRUE)
else if (j%%4 == 0)
write(paste(" {", x, ",", y, ",", z, "}}],", sep = ""),
file = filename, append = TRUE)
else write(paste(" {", x, ",", y, ",", z, "},", sep = ""),
file = filename, append = TRUE)
}
# configure general plot settings (font size, text style, etc.)
write(paste("\n}, Boxed -> False, Axes -> False, AmbientLight->GrayLevel[",
ambientlight, "], TextStyle -> {FontFamily -> \"TimesRoman\", FontSlant ->\"Italic\", FontSize -> ",
14 * cex.lab, "}, Lighting -> True, BoxRatios -> Automatic, PlotRange -> All ]\n",
sep = ""), file = filename, append = TRUE)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY>",
file = htmlout, append = TRUE)
cat(paste("<APPLET ARCHIVE=\"live.jar\" CODE=\"Live.class\" WIDTH=",
hwidth, " HEIGHT=", hheight, " ALIGN=LEFT>",
sep = ""), file = htmlout, append = TRUE)
coln <- col2rgb(col.bg)
cat(paste("<PARAM NAME=\"BGCOLOR\" VALUE=\"", rgb(red = coln[1,
]/255, green = coln[2, ]/255, blue = coln[3,
]/255), "\">", sep = ""), file = htmlout, append = TRUE)
cat("<PARAM NAME=\"MAGNIFICATION\" VALUE=1.0>", file = htmlout,
append = TRUE)
cat(paste("<PARAM NAME=\"INPUT_FILE\" VALUE=\"",
filename, "\">", sep = ""), file = htmlout, append = TRUE)
cat("</APPLET>", file = htmlout, append = TRUE)
cat("</HTML>", file = htmlout, append = TRUE)
}
# copy the Livegraphics3D live.jar to the output directory
datadir <- system.file("extdata", package = "vrmlgen")
curdir <- getwd()
if (data.class(result<-try(file.copy(file.path(datadir, "live.jar"), file.path(curdir, "live.jar")), TRUE))=="try-error")
{
warning("\nCannot copy file live.jar from vrlmgen-folder to current directory. You might need to copy the file manually.")
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# helper function to combine rotation vectors
# by quaternion multiplication
`.multquaternion` <-
function (q1, q2)
{
tmp <- numeric(4)
tmp[1] = q2[4] * q1[1] + q2[1] * q1[4] + q2[2] * q1[3] -
q2[3] * q1[2]
tmp[2] = q2[4] * q1[2] + q2[2] * q1[4] + q2[3] * q1[1] -
q2[1] * q1[3]
tmp[3] = q2[4] * q1[3] + q2[3] * q1[4] + q2[1] * q1[2] -
q2[2] * q1[1]
tmp[4] = q2[4] * q1[4] - q2[1] * q1[1] - q2[2] * q1[2] -
q2[3] * q1[3]
return(tmp)
}
# helper function to represent rotation vectors
# by quaternions
`.quaternion2rot` <-
function (quat)
{
res <- numeric(4)
res[4] = acos(quat[4]) * 2
for (i in 1:3) res[i] = quat[i]/sin(res[4]/2)
return(res)
}
# helper function to convert quaternion representations
# of rotation vectors back to the normal representation
`.rot2quaternion` <-
function (rot = c(1, 0, 0, pi))
{
res <- numeric(4)
for (i in 1:3) res[i] <- rot[i] * sin(rot[4]/2)
res[4] <- cos(rot[4]/2)
return(res)
}
# creating bar plots in VRML-format
`.vbar` <-
function (data, row.labels = rownames(data), col.labels = colnames(data),
metalabels = NULL, filename = "out.wrl", space = 0.5, cols = rainbow(length(as.matrix(data))),
rcols = NULL, ccols = NULL, origin = c(0, 0, 0), scalefac = 4, autoscale = TRUE,
ignore_zeros = TRUE, lab.axis = c("X-axis", "Y-axis", "Z-axis"), lab.vertical = FALSE,
col.axis = "black", showaxis = TRUE, col.lab = "black", col.bg = "white",
cex.lab = 1, cex.rowlab = 1, cex.collab = 1, navigation = "EXAMINE",
fov = 0.785, pos = rep(scalefac + 4, 3), dir = c(0.19, 0.45,
0.87, 2.45), transparency = 0, htmlout = NULL, hwidth = 1200,
hheight = 800, showlegend = TRUE)
{
data <- as.matrix(data)
# verify if .vbar is called within a vrmlgen-environment
# initialized with vrml.open()
scale <- 1
curdir <- NULL
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write VRML header
write("#VRML V2.0 utf8\n", file = filename, append = FALSE)
write(paste("\nViewpoint {\n\tfieldOfView", fov, "\n\tposition",
pos[1], pos[2], pos[3], "\n\torientation", dir[1],
dir[2], dir[3], dir[4], "\n\tjump TRUE\n\tdescription \"viewpoint1\"\n}\n",
sep = " "), file = filename, append = TRUE)
write(paste("\nNavigationInfo { type \"", navigation,
"\" }\n", sep = ""), file = filename, append = TRUE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}", sep = " "), file = filename,
append = TRUE)
}
else {
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
scale <- vrmlgenEnv$scale
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# scale the data to fit within the axes ranges
if(autoscale)
data <- scale * scalefac * (data/max(data))
# configure popup-text for metalabels
popuptext <- TRUE
if (is.null(metalabels)) {
popuptext <- FALSE
}
# generate popup-text
if (popuptext)
write(paste("\n\nPROTO PopupText [\n\teventIn MFString showThis\n\texposedField SFNode fontStyle FontStyle {\n\t\t\t\tjustify [ \"MIDDLE\", \"MIDDLE\" ] }\n\texposedField SFNode appearance Appearance { material Material { } } \n\tfield SFString default \"\" \n\tfield MFString stringlist [ \"\" ] \n",
paste(paste("eventIn SFBool over", 0:(length(metalabels) -
1), "\n\t", sep = "", collapse = ""), sep = "",
collapse = ""), "\t] { \nGroup { children [ \n\tDEF POPIT Script { \n\t\tfield SFString defstring IS default \n\t\tfield MFString list IS stringlist \n\t\tfield MFString strout [ \"\" ] ",
paste(paste("\n eventIn SFBool over", 0:(length(metalabels) -
1), " IS over", 0:(length(metalabels) - 1), sep = "",
collapse = "")), "\n\t\teventOut MFString string_changed \n\t\turl [ \"javascript: \n\t\tfunction evtnum(num, value) \n\t\t{ \n\t\tif (value && (num < list.length)) \n\t\t\tstrout[0] = list[num]; \n\t\telse \n\t\t\tstrout[0] = defstring; \n\t\tstring_changed = strout; \n\t\t} \n \n\t",
paste(paste("\tfunction over", 0:(length(metalabels) -
1), "(v, t) { evtnum(", 0:(length(metalabels) -
1), ", v); } \n", sep = "", collapse = "")),
"\t\", \n\t\t\"Popup.class\"] \n\t} \n\t \n\tTransform { \n\ttranslation 0 0 ",
scale * scalefac, " \n\trotation 0.28108 0.67860 0.67860 2.59356\n\t \n\tchildren Shape { \n\t\tappearance IS appearance \n\tgeometry DEF POPUP Text { \n\t\tstring \"\" \n\t\tset_string IS showThis \n\t\tfontStyle IS fontStyle \n\t\t} \n\t} \n\t} \n] } \nROUTE POPIT.string_changed TO POPUP.set_string \n} \n \n \nGroup { \nchildren DEF POP PopupText { \n\t\t#default \"Nothing selected\" \n\t\tstringlist [ ",
paste(paste("\"", metalabels[1:(length(metalabels) -
1)], "\",", sep = "", collapse = " ")), "\"",
metalabels[length(metalabels)], "\" ] \n\t} \n} \n\n",
sep = "", collapse = ""), file = filename, append = TRUE)
# draw the axes
if (showaxis) {
axis3d(lab.axis, filename, type = "vrml", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
# calculate bar-length and -width (account for scaling and spacing)
blength <- scale * scalefac/(nrow(data) * (1 + space))
bwidth <- scale * scalefac/(ncol(data) * (1 + space))
# rotate the data labels to obtain horizontal or vertical labels
rot_vec <- c(0, 0.70711, 0.70711, 3.14159)
if (lab.vertical)
rot_vec <- c(0.57735, 0.57735, 0.57735, 4.18879)
# draw row-labels
if (!is.null(row.labels) && showlegend) {
for (j in 1:length(row.labels)) {
# apply automatic color selection
colsel <- .colorselection(type = "bar", j, rcols,
1, row.labels, "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
cur_xwidth <- j/nrow(data) * scale * scalefac - blength/2
write(paste("Transform {\n\ttranslation ", cur_xwidth,
-0.4, scale * scalefac + 0.2, "\n\tscale ", cex.rowlab *
0.28, cex.rowlab * 0.28, cex.rowlab * 0.28,
"\n\trotation ", rot_vec[1], rot_vec[2], rot_vec[3],
rot_vec[4], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material {diffuseColor ",
rcol, " ", gcol, " ", bcol, " } }\n\t\tgeometry Text { string \"",
row.labels[j], "\" }\n\t}\n}", sep = " "), file = filename,
append = TRUE)
}
}
# rotate the data labels to obtain horizontal or vertical labels
rot_vec <- c(0.57735, 0.57735, 0.57735, 2.0944)
if (lab.vertical)
rot_vec <- c(0.707107, 0, 0.707107, 3.14159)
# draw column-labels
if (!is.null(col.labels) && showlegend) {
for (j in 1:length(col.labels)) {
# apply automatic color selection
colsel <- .colorselection(type = "bar", j, ccols,
1, col.labels, "")
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
cur_ywidth <- j/ncol(data) * scale * scalefac - bwidth/2
write(paste("Transform {\n\ttranslation ", -0.4,
cur_ywidth, scale * scalefac + 0.2, "\n\tscale ",
cex.collab * 0.28, cex.collab * 0.28, cex.collab *
0.28, "\n\trotation ", rot_vec[1], rot_vec[2],
rot_vec[3], rot_vec[4], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material {diffuseColor ",
rcol, " ", gcol, " ", bcol, " } }\n\t\tgeometry Text { string \"",
col.labels[j], "\" }\n\t}\n}", sep = " "), file = filename,
append = TRUE)
}
}
# initialize color and meta-label variables
popup_txt_str <- ""
popup_txt_str2 <- ""
rcol <- NULL
gcol <- NULL
bcol <- NULL
# set RGB-colors
if (length(cols) >= (ncol(data) * nrow(data))) {
rcol <- sapply(cols, function(x) (col2rgb(x)/255)[1])
gcol <- sapply(cols, function(x) (col2rgb(x)/255)[2])
bcol <- sapply(cols, function(x) (col2rgb(x)/255)[3])
}
else {
if (length(cols) >= 1) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
}
else {
rcol <- (col2rgb("lightblue")/255)[1]
gcol <- (col2rgb("lightblue")/255)[2]
bcol <- (col2rgb("lightblue")/255)[3]
}
}
# main loop: iterate over data points
counter <- 0
for (j in 1:nrow(data)) {
for (k in 1:ncol(data)) {
x <- j/nrow(data) * scale * scalefac
y <- k/ncol(data) * scale * scalefac
z <- data[j, k]
if(ignore_zeros && (z == 0))
next
counter <- counter + 1
# set current color
if (!is.null(ccols)) {
rcol <- (col2rgb(ccols[k])/255)[1]
gcol <- (col2rgb(ccols[k])/255)[2]
bcol <- (col2rgb(ccols[k])/255)[3]
}
else if (!is.null(rcols)) {
rcol <- (col2rgb(rcols[j])/255)[1]
gcol <- (col2rgb(rcols[j])/255)[2]
bcol <- (col2rgb(rcols[j])/255)[3]
}
else {
if(length(rcol) > 1)
{
rcol <- rcol[(k - 1) * ncol(data) +
j]
gcol <- gcol[(k - 1) * ncol(data) +
j]
bcol <- bcol[(k - 1) * ncol(data) +
j]
}
}
# set meta-label touch sensor
if (popuptext) {
popup_txt_str <- paste("Group {\n children [\n DEF Schalter",
(k - 1) * ncol(data) + j - 1, " TouchSensor { }",
sep = "", collapse = "")
popup_txt_str2 <- "\n]\n}"
}
# draw data point
write(paste(popup_txt_str, "Transform {\n\ttranslation ",
origin[1] + x, origin[2] + y, origin[3] + z/2,
"\n\tchildren Shape {\n\t\tappearance Appearance { material Material { diffuseColor ",
rcol, gcol, bcol, " } }\n\tgeometry Box { size ",
blength, bwidth, z, "}\n\t\t}\n}", popup_txt_str2,
sep = " "), file = filename, append = TRUE)
}
}
write("\n", file = filename, append = TRUE)
# configure interactive popup-text
if (popuptext)
write(paste("ROUTE Schalter", 0:(length(metalabels) -
1), ".isOver TO POP.over", 0:(length(metalabels) -
1), "\n", sep = "", collapse = ""), file = filename,
append = TRUE)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY><br>",
file = htmlout, append = FALSE)
cat(paste("<object type=\"x-world/x-vrml\" data=\"",
filename, "\" ", sep = ""), file = htmlout, append = TRUE)
cat(paste("width=\"", hwidth, "\" height=\"", hheight,
"\"><br>", sep = ""), file = htmlout, append = TRUE)
cat(paste("<param name=\"src\" value=\"", filename, "\"><br>",
sep = ""), file = htmlout, append = TRUE)
cat("Your browser cannot display VRML files.<br>Please INSTALL a VRML-plugin or open the file in an external VRML-viewer.</object><br>",
file = htmlout, append = TRUE)
cat("</BODY></HTML>", file = htmlout, append = TRUE)
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# creating scatter plots in VRML-format
`.vcloud` <-
function (x, y = NULL, z = NULL, labels = rownames(data), metalabels = NULL,
hyperlinks = NULL, filename = "out.wrl", pointstyle = c("s",
"b", "c"), cols = rainbow(length(unique(labels))), showdensity = FALSE,
scalefac = 4, autoscale = "independent", lab.axis = c("X-axis",
"Y-axis", "Z-axis"), col.axis = "black", showaxis = TRUE,
col.lab = "black", col.bg = "white", cex.lab = 1, navigation = "EXAMINE",
transparency = 0, fov = 0.785, pos = rep(scalefac + 4, 3),
dir = c(0.19, 0.45, 0.87, 2.45), htmlout = NULL, hwidth = 1200,
hheight = 800, showlegend = TRUE)
{
# extract the coordinate vectors from the input
xyz_parse <- xyz.coords(x, y, z)
data <- cbind(xyz_parse$x, xyz_parse$y, xyz_parse$z)
if (ncol(data) != 3) {
stop("Data matrix does not have 3 columns!")
}
# identify the unique set of row labels
numlabels <- NULL
if (length(labels)) {
lab <- unique(unlist(labels))
numlabels <- apply(as.matrix(labels), 1, function(x) match(x,
as.matrix(lab)))
}
# verify if .vcloud is called within a vrmlgen-environment
# initialized with lg3d.open()
curdir <- NULL
scale <- 1
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write VRML header
write("#VRML V2.0 utf8\n", file = filename, append = FALSE)
write(paste("\nViewpoint {\n\tfieldOfView", fov, "\n\tposition",
pos[1], pos[2], pos[3], "\n\torientation", dir[1],
dir[2], dir[3], dir[4], "\n\tjump TRUE\n\tdescription \"viewpoint1\"\n}\n",
sep = " "), file = filename, append = TRUE)
write(paste("\nNavigationInfo { type \"", navigation,
"\" }\n", sep = ""), file = filename, append = TRUE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ", bg_rcol,
bg_gcol, bg_bcol, " \n\t]\n}", sep = " "), file = filename,
append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
VRMLDir <- vrmlgenEnv$VRMLDir
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
scale <- vrmlgenEnv$scale
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# apply the chosen scaling method
scaledat <- function(data) {
diff <- max(data) - min(data)
if (diff == 0)
return(data)
else return(scale * scalefac * (data - min(data))/(diff))
}
if (autoscale == "independent")
data <- apply(data, 2, scaledat)
else if (autoscale == "equidist")
data <- scale * scalefac * (data/max(data))
# configure popup-text for metalabels
popuptext <- TRUE
if (is.null(metalabels)) {
popuptext <- FALSE
}
if (popuptext)
write(paste("\n\nPROTO PopupText [\n\teventIn MFString showThis\n\texposedField SFNode fontStyle FontStyle {\n\t\t\t\tjustify [ \"MIDDLE\", \"MIDDLE\" ] }\n\texposedField SFNode appearance Appearance { material Material { } } \n\tfield SFString default \"\" \n\tfield MFString stringlist [ \"\" ] \n",
paste(paste("eventIn SFBool over", 0:(nrow(data) -
1), "\n\t", sep = "", collapse = ""), sep = "",
collapse = ""), "\t] { \nGroup { children [ \n\tDEF POPIT Script { \n\t\tfield SFString defstring IS default \n\t\tfield MFString list IS stringlist \n\t\tfield MFString strout [ \"\" ] ",
paste(paste("\n eventIn SFBool over", 0:(nrow(data) -
1), " IS over", 0:(nrow(data) - 1), sep = "",
collapse = "")), "\n\t\teventOut MFString string_changed \n\t\turl [ \"javascript: \n\t\tfunction evtnum(num, value) \n\t\t{ \n\t\tif (value && (num < list.length)) \n\t\t\tstrout[0] = list[num]; \n\t\telse \n\t\t\tstrout[0] = defstring; \n\t\tstring_changed = strout; \n\t\t} \n \n\t",
paste(paste("\tfunction over", 0:(nrow(data) - 1),
"(v, t) { evtnum(", 0:(nrow(data) - 1), ", v); } \n",
sep = "", collapse = "")), "\t\", \n\t\t\"Popup.class\"] \n\t} \n\t \n\tTransform { \n\ttranslation 0 0 ",
scale * scalefac, " \n\trotation 0.28108 0.67860 0.67860 2.59356\n\t \n\tchildren Shape { \n\t\tappearance IS appearance \n\tgeometry DEF POPUP Text { \n\t\tstring \"\" \n\t\tset_string IS showThis \n\t\tfontStyle IS fontStyle \n\t\t} \n\t} \n\t} \n] } \nROUTE POPIT.string_changed TO POPUP.set_string \n} \n \n \nGroup { \nchildren DEF POP PopupText { \n\t\t#default \"Nothing selected\" \n\t\tstringlist [ ",
paste(paste("\"", metalabels[1:(nrow(data) - 1)],
"\",", sep = "", collapse = " ")), "\"", metalabels[nrow(data)],
"\" ] \n\t} \n} \n\n"), file = filename, append = TRUE)
# draw the plot legend
if (length(labels) && showlegend) {
cur_height <- scale * scalefac + 1.2
for (j in 1:length(unique(labels))) {
.vrmltext(0, 0, cur_height, unique(labels)[j], filename,
cols[unique(numlabels)[j]], 1, c(0.28108, 0.6786,
0.6786, 2.59356), "SANS", "NONE", NULL)
cur_height <- cur_height + 0.4
}
}
# draw the axes
if (showaxis) {
# call the axis3d helper function to draw the axes
axis3d(lab.axis, filename, type = "vrml", col.lab, col.axis,
cex.lab, local_scale = scalefac, global_scale = 1)
}
# initialize color and meta-label variables
popup_txt_str <- ""
popup_txt_str2 <- ""
hyperlink <- NULL
# main loop: iterate over data points
for (j in 1:nrow(data)) {
x <- data[j, 1]
y <- data[j, 2]
z <- data[j, 3]
# apply automatic color selection
colsel <- .colorselection(type = "cloud", j, cols, nrow(data),
labels, numlabels)
rcol <- colsel$rcol
gcol <- colsel$gcol
bcol <- colsel$bcol
if (popuptext) {
popup_txt_str <- paste("Group {\n children [\n DEF Schalter",
j - 1, " TouchSensor { }", sep = "", collapse = "")
popup_txt_str2 <- "\n]\n}"
}
if (!is.null(hyperlinks)) {
hyperlink <- hyperlinks[j]
}
# draw data point with given point-style
# and popup-text for meta-labels
if (length(pointstyle) == 1) {
write(popup_txt_str, file = filename, append = TRUE)
# call lower level plotting function to draw datapoints
.vrmlpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle, hyperlinks = hyperlink, global_scale = 1,
local_scale = 1, transparency)
write(popup_txt_str2, file = filename, append = TRUE)
}
else if (length(pointstyle) >= length(unique(numlabels))) {
if (length(labels)) {
stylevec <- c("s", "b", "c")
curstyle <- stylevec[numlabels[j]]
write(popup_txt_str, file = filename, append = TRUE)
.vrmlpoints(x, y, z, filename, rcol, gcol, bcol,
curstyle, hyperlinks = hyperlink, global_scale = 1,
local_scale = 1, transparency)
write(popup_txt_str2, file = filename, append = TRUE)
}
else {
popup_txt_str <- ""
popup_txt_str2 <- ""
write(popup_txt_str, file = filename, append = TRUE)
.vrmlpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle[1], hyperlinks = hyperlink, global_scale = 1,
local_scale = 1, transparency)
write(popup_txt_str2, file = filename, append = TRUE)
}
}
else {
write(popup_txt_str, file = filename, append = TRUE)
.vrmlpoints(x, y, z, filename, rcol, gcol, bcol,
pointstyle[1], hyperlinks = hyperlink, global_scale = 1,
local_scale = 1, transparency)
write(popup_txt_str2, file = filename, append = TRUE)
}
}
write("\n", file = filename, append = TRUE)
# configure interactive popup-text
if (popuptext)
write(paste("ROUTE Schalter", 0:(nrow(data) - 1), ".isOver TO POP.over",
0:(nrow(data) - 1), "\n", sep = "", collapse = ""),
file = filename, append = TRUE)
# draw density estimation contour surfaces
if (showdensity)
est <- .vdense(data, filename)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML outputr
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY><br>",
file = htmlout, append = FALSE)
cat(paste("<object type=\"x-world/x-vrml\" data=\"",
filename, "\" ", sep = ""), file = htmlout, append = TRUE)
cat(paste("width=\"", hwidth, "\" height=\"", hheight,
"\"><br>", sep = ""), file = htmlout, append = TRUE)
cat(paste("<param name=\"src\" value=\"", filename, "\"><br>",
sep = ""), file = htmlout, append = TRUE)
cat("Your browser cannot display VRML files.<br>Please INSTALL a VRML-plugin or open the file in an external VRML-viewer.</object><br>",
file = htmlout, append = TRUE)
cat("</BODY></HTML>", file = htmlout, append = TRUE)
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
# helper function for density estimation contour surface computation
`.vdense` <-
function (x, filename)
{
nobs <- nrow(x)
ndim <- ncol(x)
weights <- rep(1, nobs)
# compute number of bins (depending on number of observations)
nbins <- round((nobs > 500) * 8 * log(nobs)/ndim)
# compute number of breaks
if (nbins > 0) {
breaks <- cbind(seq(min(x[, 1]), max(x[, 1]), length = nbins +
1), seq(min(x[, 2]), max(x[, 2]), length = nbins +
1))
f1 <- cut(x[, 1], breaks = breaks[, 1])
f2 <- cut(x[, 2], breaks = breaks[, 2])
f3 <- cut(x[, 3], breaks = breaks[, 3])
freq <- table(f1, f2, f3)
dimnames(freq) <- NULL
midpoints <- (breaks[-1, ] + breaks[-(nbins + 1), ])/2
z1 <- midpoints[, 1]
z2 <- midpoints[, 2]
z3 <- midpoints[, 3]
X <- as.matrix(expand.grid(z1, z2, z3))
X.f <- as.vector(freq)
id <- (X.f > 0)
X <- X[id, ]
dimnames(X) <- list(NULL, dimnames(x)[[2]])
X.f <- X.f[id]
bins <- list(x = X, x.freq = X.f, midpoints = midpoints,
breaks = breaks, table.freq = freq)
x <- bins$x
weights <- bins$x.freq
nx <- length(bins$x.freq)
}
else nx <- nobs
h <- .hnorm(x, weights)
rawdata <- list(nbins = nbins, x = x, nobs = nobs, ndim = ndim)
# calculate density estimation contours
est <- .vdensecalc(x, h = h, weights = weights, rawdata = rawdata,
filename = filename)
return(TRUE)
}
# compute density estimation contour surfaces
`.vdensecalc` <-
function (x, h = .hnorm(x, weights), eval.points = NULL, weights = rep(1,
length(x)), rawdata = list(), eval.type = "grid", filename = "test.wrl")
{
# intial settings
xlim <- range(x[, 1])
ylim <- range(x[, 2])
zlim <- range(x[, 3])
ngrid <- 20
if (eval.type != "points") {
evp <- cbind(seq(xlim[1], xlim[2], length = ngrid), seq(ylim[1],
ylim[2], length = ngrid), seq(zlim[1], zlim[2], length = ngrid))
eval.points <- evp
}
h.weights <- rep(1, nrow(x))
n <- nrow(x)
nnew <- nrow(eval.points)
hmult <- 1
# compute density estimation
result <- list(eval.points = eval.points, h = h * hmult,
h.weights = h.weights, weights = weights)
Wh <- matrix(rep(h.weights, nnew), ncol = n, byrow = TRUE)
W1 <- matrix(rep(eval.points[, 1], rep(n, nnew)), ncol = n,
byrow = TRUE)
W1 <- W1 - matrix(rep(x[, 1], nnew), ncol = n, byrow = TRUE)
W1 <- exp(-0.5 * (W1/(hmult * h[1] * Wh))^2)/Wh
W2 <- matrix(rep(eval.points[, 2], rep(n, nnew)), ncol = n,
byrow = TRUE)
W2 <- W2 - matrix(rep(x[, 2], nnew), ncol = n, byrow = TRUE)
W2 <- exp(-0.5 * (W2/(hmult * h[2] * Wh))^2)/Wh
W3 <- matrix(rep(eval.points[, 3], rep(n, nnew)), ncol = n,
byrow = TRUE)
W3 <- W3 - matrix(rep(x[, 3], nnew), ncol = n, byrow = TRUE)
W3 <- exp(-0.5 * (W3/(hmult * h[3] * Wh))^2)/Wh
if (eval.type == "points") {
est <- as.vector(((W1 * W2 * W3) %*% weights)/(sum(weights) *
(2 * pi)^1.5 * h[1] * h[2] * h[3] * hmult^3))
return(est)
}
est <- .vdensecalc(x, h, x, eval.type = "points", weights = weights,
filename = filename)
props <- c(75, 50, 25)
# set colors for different density levels
cols <- topo.colors(length(props))
alpha <- seq(1, 0.5, length = length(props))
levels <- quantile(est, props/100)
est <- apply(W3, 1, function(x) (W1 %*% (weights * x * t(W2)))/(sum(weights) *
(2 * pi)^1.5 * h[1] * h[2] * h[3] * hmult^3))
est <- array(c(est), dim = rep(ngrid, 3))
struct <- NULL
# use misc3d to compute the final contours
if (require(misc3d)) {
struct <- contour3d(est, levels, eval.points[, 1], eval.points[,
2], eval.points[, 3], engine = "none")
} else {
stop("In order to draw contour surfaces, please first install the misc3d package!")
}
# write output to VRML file
for (i in 1:length(props)) {
if (length(props) > 1)
strct <- struct[[i]]
else strct <- struct
trngs.x <- c(t(cbind(strct$v1[, 1], strct$v2[, 1], strct$v3[,
1])))
trngs.y <- c(t(cbind(strct$v1[, 2], strct$v2[, 2], strct$v3[,
2])))
trngs.z <- c(t(cbind(strct$v1[, 3], strct$v2[, 3], strct$v3[,
3])))
a <- list(x = trngs.x, y = trngs.y, z = trngs.z)
rcol <- (col2rgb(cols[i])/255)[1]
gcol <- (col2rgb(cols[i])/255)[2]
bcol <- (col2rgb(cols[i])/255)[3]
# write contours to VRML file
for (j in seq(1, length(trngs.x), 3)) {
write(paste("\n Shape { \n\tappearance Appearance {\n\t\t material Material {\n\t\tdiffuseColor ",
rcol, " ", gcol, " ", bcol, "\n\t\ttransparency ",
alpha[i], " \n\t}\n\t}\t\n \n\t geometry IndexedFaceSet {\n\t \t\tsolid TRUE \t \n\t\tcoord Coordinate {\n\t\t\t point [\n\t\t\t ",
trngs.x[j], trngs.y[j], trngs.z[j], " \n\t\t\t ",
trngs.x[j + 1], trngs.y[j + 1], trngs.z[j + 1],
" \n\t\t\t ", trngs.x[j + 2], trngs.y[j + 2],
trngs.z[j + 2], " \n\t\t ]\n\t }\n\t coordIndex [\t0 1 2\t] \n\t}\t \n }\n ",
sep = " "), file = filename, append = TRUE)
}
}
return(est)
}
# helper function for density estimation contour surface computation
`.hnorm` <-
function (x, weights = NA)
{
if (all(is.na(weights)))
weights <- rep(1, nrow(x))
ndim <- ncol(as.matrix(x))
if (ndim != 3)
stop("only data with 3 dimensions is allowed.")
n <- sum(weights)
sd <- sqrt(apply(x, 2, function(x, w) {
sum(w * (x - sum(x * w)/sum(w))^2)/(sum(w) - 1)
}, w = weights))
hh <- sd * (4/(5 * n))^(1/7)
hh
}
# creating 3D-meshes in VRML-format
`.vmesh` <-
function (infile = NULL, x = NULL, y = NULL, z = NULL, edges = NULL,
xfun = "sin(v)*cos(u)", yfun = "sin(v)*sin(u)", zfun = "cos(v)",
param1 = "u", param2 = "v", range1 = c(0, 2 * pi), range2 = c(0,
pi), size1 = 30, size2 = 30, write_obj = FALSE, filename = "out.wrl",
cols = "red", scalefac = 4, autoscale = ifelse(is.null(infile),
"independent", "equicenter"), lab.axis = c("X-axis",
"Y-axis", "Z-axis"), col.axis = "black", showaxis = TRUE,
col.lab = "black", col.bg = "white", cex.lab = 1, navigation = "EXAMINE",
transparency = 0, fov = 0.785, pos = rep(scalefac + 4, 3),
dir = c(0.19, 0.45, 0.87, 2.45), htmlout = NULL, hwidth = 1200,
hheight = 800)
{
# write output in obj-format, if write_obj == TRUE and vertex-
# and edge-data is available
if (write_obj) {
if (is.null(x) && is.null(edges)) {
stop("\nThe generation of obj-files is currently only supported, when using vertex-coordinates (x, y, z-parameters) and polygonal face indices (edges-parameter) as input.")
}
# write OBJ header
write("# OBJ file created by VRMLgen\n#\n", file = filename,
append = FALSE)
# extract coordinate vectors from input
xyz_parse <- xyz.coords(x, y, z)
# generate the OBJ output file
write(paste("v", xyz_parse$x, xyz_parse$y, xyz_parse$z,
sep = " "), file = filename, append = TRUE)
write("\n", file = filename, append = TRUE)
for (i in 1:nrow(edges)) {
write(paste("f", paste(edges[i, ], collapse = " "),
sep = " "), file = filename, append = TRUE)
}
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
# check which input is supplied:
else {
# case 1: the user provides an obj-file as input
if (!is.null(infile)) {
# read the obj-file
obj <- strsplit(readLines(infile), "\t")
# collect face data
faces <- which(as.numeric(lapply(obj, function(x) grep("^f",
x[1]))) == 1)
# collect node data
nodes <- which(as.numeric(lapply(obj, function(x) grep("^v ",
x[1]))) == 1)
# parse node data
tmpmat <- lapply(obj[nodes], function(x) strsplit(x,
" ")[[1]])
# extract edges from faces
redmat <- t(sapply(tmpmat, function(x) as.numeric(x[2:length(x)])))
data <- redmat[, which(apply(redmat, 2, function(x) !any(is.na(x))))]
edges_lst <- lapply(obj[faces], function(x) strsplit(x,
" ")[[1]])
edges_filt1 <- lapply(edges_lst, function(y) as.numeric(sapply(y[2:length(y)],
function(x) strsplit(x, "/")[[1]][1])))
edges_filt <- lapply(edges_filt1, function(x) x[which(!is.na(x))])
# split faces with more than 4 edges into smaller faces
filter <- sapply(edges_filt, length) > 4
filt <- edges_filt[filter]
reduced_lst <- NULL
if (length(filt) > 0) {
for (j in 1:length(filt)) {
reduced_lst <- c(reduced_lst, list(filt[[j]][1:4]))
for (k in seq(4, length(filt[[j]]), 3)) {
if (!is.na(filt[[j]][k + 2])) {
reduced_lst <- c(reduced_lst, list(c(filt[[j]][k:(k +
2)], filt[[j]][1])))
}
else if (!is.na(filt[[j]][k + 1])) {
reduced_lst <- c(reduced_lst, list(c(filt[[j]][k:(k +
1)], filt[[j]][1], 0)))
break
}
else {
break
}
}
}
}
# combine edge data
comb_lst <- c(edges_filt[!filter], reduced_lst)
filtless <- which(sapply(comb_lst, length) < 4)
comb_lst[filtless] <- lapply(comb_lst[filtless],
function(x) c(x, 0))
all(sapply(comb_lst, length) == 4)
edges <- t(sapply(comb_lst, rbind)) - 1
}
# case 2: a parametric function is used as input
else if (is.null(x)) {
# check if the required data is available
if (is.null(xfun) || is.null(yfun) || is.null(zfun)) {
stop("Either the paramater infile or data or the parameters xfun, yfun and zfun have to be specified.")
}
if (is.null(param1) || is.null(param2)) {
stop("The parameter names param1 and param2 have not been specified")
}
# initialize variables
x <- NULL
y <- NULL
z <- NULL
smin <- range1[1]
smax <- range1[2]
tmin <- range2[1]
tmax <- range2[2]
sn <- size1
tn <- size2
ds <- (smax - smin)/sn
dt <- (tmax - tmin)/tn
# compute the data points representing the parametric function
for (i in seq(smin, (smax - ds/2), ds)) {
for (j in seq(tmin, (tmax - dt/2), dt)) {
eval(parse(text = paste(param1, " <- ", i)))
eval(parse(text = paste(param2, " <- ", j)))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param1, " <- ", param1,
" + ds")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param2, " <- ", param2,
" + dt")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
eval(parse(text = paste(param1, " <- ", param1,
" - ds")))
x <- c(x, eval(parse(text = xfun)))
y <- c(y, eval(parse(text = yfun)))
z <- c(z, eval(parse(text = zfun)))
}
}
# combine data
data <- as.matrix(cbind(x, y, z))
}
else {
# mesh vertex data is directly provided as input
xyz_parse <- xyz.coords(x, y, z)
data <- cbind(xyz_parse$x, xyz_parse$y, xyz_parse$z)
}
if (ncol(data) != 3) {
stop("Data matrix does not have 3 columns!")
}
# verify if .lbar is called within a vrmlgen-environment
# initialized with vrml.open()
scale <- 1
curdir <- NULL
if (!exists(".vrmlgenEnv")) {
# set the general 3D scene settings, if they are
# not provided by a higher-level environment
# write VRML header
write("#VRML V2.0 utf8\n", file = filename, append = FALSE)
write(paste("\nViewpoint {\n\tfieldOfView", fov,
"\n\tposition", pos[1], pos[2], pos[3], "\n\torientation",
dir[1], dir[2], dir[3], dir[4], "\n\tjump TRUE\n\tdescription \"viewpoint1\"\n}\n",
sep = " "), file = filename, append = TRUE)
write(paste("\nNavigationInfo { type \"", navigation,
"\" }\n", sep = ""), file = filename, append = TRUE)
# set background color
bg_rcol <- (col2rgb(col.bg)/255)[1]
bg_gcol <- (col2rgb(col.bg)/255)[2]
bg_bcol <- (col2rgb(col.bg)/255)[3]
write(paste("Background {\n\t skyColor [\n\t\t ",
bg_rcol, bg_gcol, bg_bcol, " \n\t]\n}", sep = " "),
file = filename, append = TRUE)
}
else {
# obtain the general settings from the
# higher level environment
vrmlgenEnv <- get(".vrmlgenEnv",envir=.GlobalEnv)
filename <- vrmlgenEnv$filename
htmlout <- vrmlgenEnv$html
hheight <- vrmlgenEnv$hheight
hwidth <- vrmlgenEnv$hwidth
scale <- vrmlgenEnv$scale
curdir <- getwd()
setwd(vrmlgenEnv$VRMLDir)
}
# apply the chosen scaling method
scaledat <- function(data) {
diff <- max(data) - min(data)
if (diff == 0)
return(data)
else return(scale * scalefac * (data - min(data))/(diff))
}
if (autoscale == "independent")
data <- apply(data, 2, scaledat)
else if (autoscale == "equidist")
data <- scale * scalefac * (data/max(data))
else if (autoscale == "equicenter")
data <- scale * scalefac/2 * data/max(data) + scalefac/2
# draw the axes
if (showaxis) {
# call the axis3d helper function to draw the axes
axis3d(lab.axis, filename, type = "vrml", col.lab,
col.axis, cex.lab, local_scale = scalefac, global_scale = 1)
}
# write the data point coordinates
write(paste("Transform {\nscale 1.0 1.0 1.0\n\tchildren [\n\t\tShape {\n\t\t\tappearance Appearance{ material Material{ transparency ",transparency,"}}\n",
sep = " "), file = filename, append = TRUE)
write(paste("\n\t\t\tgeometry IndexedFaceSet {\n\t\t\tcoord DEF\n\tVertexArray Coordinate{\n\tpoint [\n",
sep = " "), file = filename, append = TRUE)
for (j in 1:nrow(data)) {
write(paste(paste(data[j, ], collapse = " "), ",\n",
sep = ""), file = filename, append = TRUE)
}
write("]\n}\n", file = filename, append = TRUE)
# write the edges (using coordinate indices)
write("coordIndex [\n", file = filename, append = TRUE)
mat <- NULL
if (!is.null(edges)) {
mat <- edges
while (ncol(mat) < 4) {
mat <- cbind(mat, rep(-1, nrow(mat)))
}
}
else {
mat <- matrix(1:nrow(data), ncol = 4, byrow = TRUE) -
1
}
for (j in 1:nrow(mat)) {
write(paste(paste(mat[j, ], collapse = " "), "-1",
sep = " "), file = filename, append = TRUE)
}
# write vertex colors
write(paste("]\n solid FALSE\n colorPerVertex TRUE\n color \nDEF VertexColorArray Color{\ncolor [",
sep = ""), file = filename, append = TRUE)
# use rainbow colors if no colors are pre-defined
if (!length(cols) || (is.null(cols))) {
cols <- rainbow(nrow(data))
mat <- sapply(cols, function(x) (col2rgb(x)/255))
for (j in 1:nrow(data)) {
write(paste(mat[1, j], mat[2, j], mat[3, j],
",\n", collapse = " "), file = filename, append = TRUE)
}
}
# use a single color if the number of colors is less than the number of data rows
else if ((length(cols) == 1) || (length(cols) < nrow(data))) {
rcol <- (col2rgb(cols[1])/255)[1]
gcol <- (col2rgb(cols[1])/255)[2]
bcol <- (col2rgb(cols[1])/255)[3]
for (j in 1:nrow(data)) {
write(paste(rcol, gcol, bcol, ",\n", collapse = " "),
file = filename, append = TRUE)
}
}
else {
mat <- sapply(cols, function(x) (col2rgb(x)/255))
for (j in 1:nrow(data)) {
write(paste(mat[1, j], mat[2, j], mat[3, j],
",\n", collapse = " "), file = filename, append = TRUE)
}
}
write(paste("]\n}\n}\n}\n]\n}", sep = ""), file = filename,
append = TRUE)
# create the output files, if this is not already
# done by a higher-level lg3d.close-function
if (!exists(".vrmlgenEnv")) {
# create HTML output
if (!is.null(htmlout)) {
cat("<HTML>", file = htmlout, append = FALSE)
cat("<HEAD><TITLE>VRMLGen-visualization</TITLE></HEAD><BODY><br>",
file = htmlout, append = FALSE)
cat(paste("<object type=\"x-world/x-vrml\" data=\"",
filename, "\" ", sep = ""), file = htmlout,
append = TRUE)
cat(paste("width=\"", hwidth, "\" height=\"",
hheight, "\"><br>", sep = ""), file = htmlout,
append = TRUE)
cat(paste("<param name=\"src\" value=\"", filename,
"\"><br>", sep = ""), file = htmlout, append = TRUE)
cat("Your browser cannot display VRML files.<br>Please INSTALL a VRML-plugin or open the file in an external VRML-viewer.</object><br>",
file = htmlout, append = TRUE)
cat("</BODY></HTML>", file = htmlout, append = TRUE)
}
# show success message
cat(paste("\nOutput file \"", filename, "\" was generated in folder ",
getwd(), ".\n", sep = ""))
}
else {
# return to current directory, if higher-level plotting
# functions wrote re-directed the output to a temporary directory
setwd(curdir)
}
}
}
# lower-level function for plotting data points in the VRML-format
`.vrmlpoints` <-
function (x, y, z, filename, rcol, gcol, bcol, pointstyle, hyperlinks = NULL,
global_scale = 1, local_scale = 1, transparency = 0)
{
# add hyperlinks to the data points
hyperlinks_start <- rep("", length(x))
hyperlinks_end <- rep("", length(x))
if (!is.null(hyperlinks)) {
hyperlinks_start <- paste("\n\tchildren Anchor { url \"",
hyperlinks, "\"", sep = "")
hyperlinks_end <- rep("}", length(x))
}
# check the point-style and draw the data points at the
# corresponding coordinates
if (pointstyle == "s") {
for (i in 1:length(x))
write(paste("\nTransform {\n\ttranslation ",
x[i] * global_scale, y[i] * global_scale, z[i] *
global_scale, hyperlinks_start[i], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material { diffuseColor",
rcol, gcol, bcol, "transparency", transparency, "} }\n\tgeometry Sphere { radius ",
0.08 * local_scale, "}\n\t\t}", hyperlinks_end[i],
"\n}", sep = " "), file = filename, append = TRUE)
}
else if (pointstyle == "c") {
for (i in 1:length(x))
write(paste("\nTransform {\n\trotation 1 0 0 1.5708\n\ttranslation ",
x[i] * global_scale, y[i] * global_scale, z[i] *
global_scale, hyperlinks_start[i], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material { diffuseColor",
rcol, gcol, bcol, "transparency", transparency, "} }\n\tgeometry Cone { bottomRadius ",
0.08 * local_scale, "height", 0.08 * local_scale,
"\n\t\tside TRUE}\n\t\t}", hyperlinks_end[i], "\n}",
sep = " "), file = filename, append = TRUE)
}
else {
for (i in 1:length(x))
write(paste("\nTransform {\n\ttranslation ",
x[i] * global_scale, y[i] * global_scale, z[i] *
global_scale, hyperlinks_start[i], "\n\tchildren Shape {\n\t\tappearance Appearance { material Material { diffuseColor",
rcol, gcol, bcol, "transparency", transparency, "} }\n\tgeometry Box { size ",
0.08 * local_scale, 0.08 * local_scale, 0.08 * local_scale,
"}\n\t\t}", hyperlinks_end[i], "\n}", sep = " "),
file = filename, append = TRUE)
}
}
# lower-level function for adding text to a 3D-scene
# in the Livegraphics3D-format
`.vrmltext` <-
function (x, y, z, text, filename, col, scale, rot, fontfamily,
fontweight, hyperlink)
{
# convert the color to RGB-format
rcol <- (col2rgb(col)/255)[1]
gcol <- (col2rgb(col)/255)[2]
bcol <- (col2rgb(col)/255)[3]
# add hyperlinks to the text
if (is.null(hyperlink)) {
for (i in 1:length(x))
write(paste("Transform {\n\ttranslation ",
x[i], y[i], z[i], "\n\tscale ", 0.28, 0.28, 0.28,
"\n\trotation ", rot[1], rot[2], rot[3], rot[4],
"\n\tchildren Shape {\n\t\tappearance Appearance { material Material {diffuseColor ",
rcol, gcol, bcol, " } }\n\tgeometry Text { string \"",
text[i], "\"\nfontStyle FontStyle {\nsize ", scale,
"\nfamily [\"", fontfamily, "\"]\njustify \"MIDDLE\"\n style \"",
fontweight, "\" }\n }\n\t}\n}", sep = " "), file = filename,
append = TRUE)
}
else {
for (i in 1:length(x))
write(paste("Transform {\n\ttranslation ",
x[i], y[i], z[i], "\n\tscale ", 0.28, 0.28, 0.28,
"\n\trotation ", rot[1], rot[2], rot[3], rot[4],
"\n\tchildren Anchor { url \"", hyperlink, "\" \n\tchildren Shape {\n\t\tappearance Appearance { material Material {diffuseColor ",
rcol, gcol, bcol, " } }\n\tgeometry Text { string \"",
text[i], "\"\nfontStyle FontStyle {\nsize ", scale,
"\nfamily [\"SANS\"]\njustify \"MIDDLE\"\n style \"",
fontweight, "\" }\n }\n\t}\n}\n}", sep = " "), file = filename,
append = TRUE)
}
}
Try the vrmlgen 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.