R/drawHiveSpline.R

Defines functions drawHiveSpline

Documented in drawHiveSpline

#' Draw a 3D Spline as Part of a 3D Hive Plot
#' 
#' This function analyzes the edges of a \code{HivePlotData} object in order to
#' draw 3D splines representing those edges.  Each pair of nodes at the ends of
#' an edge is identified, and a control point is computed.  This information is
#' passed to \code{\link{rcsr}} to work out the details.
#' 
#' 
#' @param HPD An object of S3 class \code{HivePlotData}.
#'
#' @param L_A Logical: should splines be drawn with \code{line_antialias =
#' TRUE}?
#'
#' @param \dots Parameters to be passed downstream.
#'
#' @return None.  A spline is added to the 3D hive plot in progress.
#'
#' @author Bryan A. Hanson, DePauw University. \email{[email protected]@depauw.edu}
#'
#' @seealso \code{\link{plot3dHive}} which calls this function and is the user
#' interface.
#'
#' @keywords plot hplot
#'
#' @export drawHiveSpline
#'
#' @importFrom rgl lines3d
#'
drawHiveSpline <- function(HPD, L_A = FALSE, ...) {
	
	# Function to locate a 3d spline curve in a particular n dimensional
	# system & figure out the control point
	
	# For use with plot3dHive
	# Bryan Hanson, DePauw University, Feb 2011 and onward

	if (!requireNamespace("rgl", quietly = TRUE)) {
		stop("You need to install package rgl to use this function")
		}
	
	# The point pairs to be connected given by df edges
	
	chkHPD(HPD)
	nodes <- HPD$nodes
	edges <- HPD$edges		
	nx <- length(unique(nodes$axis))
	if ((nx == 2) | (nx == 3)) stop("You shouldn't be calling this function w/2 or 3 axes")

##### Get the edges data frame ready

	ax1 <- rad1 <- ax2 <- rad2 <- c()

	for (n in 1:nrow(edges)) {
		pat1 <- paste("\\b", edges$id1[n], "\\b", sep = "") 
		pat2 <- paste("\\b", edges$id2[n], "\\b", sep = "")
		id1 <- grep(pat1, nodes$id)
		id2 <- grep(pat2, nodes$id)

		ax1 = c(ax1, nodes$axis[id1])
		rad1 = c(rad1, nodes$radius[id1])
		ax2 = c(ax2, nodes$axis[id2])
		rad2 = c(rad2, nodes$radius[id2])
		}
		
	ds <- data.frame(ax1, rad1, ax2, rad2)
	ds$phi1 <- ds$phi2 <- ds$th1 <- ds$th2 <- rep(NA, length(ds$ax1))
	
##### 4D, This requires a 3D spline curve to be drawn

	if (nx == 4) {

		for (n in 1:nrow(ds)) {
			if (ds$ax1[n] == 1) {ds$phi1[n] = 54.7; ds$th1[n] = 45}
			if (ds$ax1[n] == 2) {ds$phi1[n] = 125.3; ds$th1[n] = -45}
			if (ds$ax1[n] == 3) {ds$phi1[n] = 125.3; ds$th1[n] = 135}
			if (ds$ax1[n] == 4) {ds$phi1[n] = 54.7; ds$th1[n] = -135}
			
			if (ds$ax2[n] == 1) {ds$phi2[n] = 54.7; ds$th2[n] = 45}
			if (ds$ax2[n] == 2) {ds$phi2[n] = 125.3; ds$th2[n] = -45}
			if (ds$ax2[n] == 3) {ds$phi2[n] = 125.3; ds$th2[n] = 135}
			if (ds$ax2[n] == 4) {ds$phi2[n] = 54.7; ds$th2[n] = -135}
			}
	
	pt1 <- data.frame(radius = ds$rad1, theta = ds$th1, phi = ds$phi1)	
	pt2 <- data.frame(radius = ds$rad2, theta = ds$th2, phi = ds$phi2)
	pt1 <- sph2cart(pt1)
	pt2 <- sph2cart(pt2)
	
	# Compute control point, then create splines
	# Splines must be drawn one at a time (slow!)

	cp <- 0.6*(pt1 + pt2)
	
	pt1 <- as.matrix(pt1)
	cp <- as.matrix(cp)
	pt2 <- as.matrix(pt2)

		for (n in 1:nrow(pt1)) {
			spl <- rcsr(p0 = pt1[n,], cp = cp[n,], p1 = pt2[n,])
			rgl::lines3d(x = spl[,1], y = spl[,2], z = spl[,3],
				line_antialias = L_A, col = edges$color[n], lwd = edges$weight[n])		
			}
	
		} # end of nx = 4

##### 5D, This requires a 3D spline curve to be drawn
	
	if (nx == 5) {
	
		for (n in 1:nrow(ds)) {
			if (ds$ax1[n] == 1) {ds$phi1[n] = 90; ds$th1[n] = 0}
			if (ds$ax1[n] == 2) {ds$phi1[n] = 90; ds$th1[n] = 120}
			if (ds$ax1[n] == 3) {ds$phi1[n] = 90; ds$th1[n] = 240}
			if (ds$ax1[n] == 4) {ds$phi1[n] = 0; ds$th1[n] = 0}
			if (ds$ax1[n] == 5) {ds$phi1[n] = 180; ds$th1[n] = 0}
			
			if (ds$ax2[n] == 1) {ds$phi2[n] = 90; ds$th2[n] = 0}
			if (ds$ax2[n] == 2) {ds$phi2[n] = 90; ds$th2[n] = 120}
			if (ds$ax2[n] == 3) {ds$phi2[n] = 90; ds$th2[n] = 240}
			if (ds$ax2[n] == 4) {ds$phi2[n] = 0; ds$th2[n] = 0}
			if (ds$ax2[n] == 5) {ds$phi2[n] = 180; ds$th2[n] = 0}
			}
	
	pt1 <- data.frame(radius = ds$rad1, theta = ds$th1, phi = ds$phi1)	
	pt2 <- data.frame(radius = ds$rad2, theta = ds$th2, phi = ds$phi2)
	pt1 <- sph2cart(pt1)
	pt2 <- sph2cart(pt2)

	# Compute control point, then create splines
	# Splines must be drawn one at a time (slow!)

	cp <- 0.6*(pt1 + pt2)
	
	pt1 <- as.matrix(pt1)
	cp <- as.matrix(cp)
	pt2 <- as.matrix(pt2)
		for (n in 1:nrow(pt1)) {
			spl <- rcsr(p0 = pt1[n,], cp = cp[n,], p1 = pt2[n,])
			rgl::lines3d(x = spl[,1], y = spl[,2], z = spl[,3],
				line_antialias = L_A, col = edges$color[n], lwd = edges$weight[n])		
			}
	
		} # end of nx = 5

##### 6D, This requires a 3D spline curve to be drawn
	
	if (nx == 6) {
	
		for (n in 1:nrow(ds)) {
			if (ds$ax1[n] == 1) {ds$phi1[n] = 90; ds$th1[n] = 0}
			if (ds$ax1[n] == 2) {ds$phi1[n] = 90; ds$th1[n] = 90}
			if (ds$ax1[n] == 3) {ds$phi1[n] = 90; ds$th1[n] = 180}
			if (ds$ax1[n] == 4) {ds$phi1[n] = 90; ds$th1[n] = 270}
			if (ds$ax1[n] == 5) {ds$phi1[n] = 0; ds$th1[n] = 0}
			if (ds$ax1[n] == 6) {ds$phi1[n] = 180; ds$th1[n] = 0}
			
			if (ds$ax2[n] == 1) {ds$phi2[n] = 90; ds$th2[n] = 0}
			if (ds$ax2[n] == 2) {ds$phi2[n] = 90; ds$th2[n] = 90}
			if (ds$ax2[n] == 3) {ds$phi2[n] = 90; ds$th2[n] = 180}
			if (ds$ax2[n] == 4) {ds$phi2[n] = 90; ds$th2[n] = 270}
			if (ds$ax2[n] == 5) {ds$phi2[n] = 0; ds$th2[n] = 0}
			if (ds$ax2[n] == 6) {ds$phi2[n] = 180; ds$th2[n] = 0}
			}
	
	pt1 <- data.frame(radius = ds$rad1, theta = ds$th1, phi = ds$phi1)	
	pt2 <- data.frame(radius = ds$rad2, theta = ds$th2, phi = ds$phi2)
	pt1 <- sph2cart(pt1)
	pt2 <- sph2cart(pt2)

	# Compute control point, then create splines
	# Splines must be drawn one at a time (slow!)

	cp <- 0.6*(pt1 + pt2)
	
	pt1 <- as.matrix(pt1)
	cp <- as.matrix(cp)
	pt2 <- as.matrix(pt2)
		for (n in 1:nrow(pt1)) {
			spl <- rcsr(p0 = pt1[n,], cp = cp[n,], p1 = pt2[n,])
			rgl::lines3d(x = spl[,1], y = spl[,2], z = spl[,3],
				line_antialias = L_A, col = edges$color[n], lwd = edges$weight[n])		
			}
	
		} # end of nx = 6

	
	} # closing brace, this is the very end!

Try the HiveR package in your browser

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

HiveR documentation built on May 2, 2019, 2:08 a.m.