R/3Dplotting.R

In abnormally-distributed/abdisttools: Random Functions for Personal Use

#' @importFrom magrittr "%>%"
#' @importFrom scales "rescale"
#' @importFrom dplyr "mutate"
#' @importFrom dplyr "bind_rows"
#' @importFrom plot3D "perspbox"
#' @importFrom plot3D "trans3D"

Axes3D = ggproto("Axes3D", Stat,
                 compute_group = function(data, scales, theta=0, phi=0 ) {
                   
                   pmat = plot3D::perspbox(z=diag(2), plot=F, theta=theta, phi=phi)
                   
                   x_axis = plot3D::trans3D(x = 0:1, y = 0, z = 0, pmat = pmat) %>%
                     data.frame() %>%
                     mutate(axis="x")
                   y_axis = plot3D::trans3D(x = 0, y = 0:1, z = 0, pmat = pmat) %>%
                     data.frame() %>%
                     mutate(axis="y")
                   z_axis = plot3D::trans3D(x = 0, y = 0, z = 0:1, pmat = pmat) %>%
                     data.frame() %>%
                     mutate(axis="z")
                   
                   Axes = bind_rows(x_axis, y_axis, z_axis)
                   
                   Axes
                 },
                 
                 required_aes = c("x", "y", "z")
)

#' Draw 3D Axes
#'
#' This function adds 3D axes to a ggplot2 plot.
#'
#' @param theta The azimuthal direction in degrees.
#' @param phi The colatitude in degrees.
#' @param ... Arguements passed on to layer.
#' These are often aesthetics, used to set an
#' aesthetic to a fixed value, like color = "red" or size = 3.
#' @export
axes_3D = function(mapping = aes(group=1), data = NULL, geom = "path",
                   position = "identity", na.rm = FALSE, show.legend = NA,
                   inherit.aes = TRUE, ...) {
  layer(
    stat = Axes3D, data = data, mapping = mapping, geom = geom,
    position = position, show.legend = FALSE, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

#' @importFrom magrittr "%>%"
#' @importFrom scales "rescale"
#' @importFrom dplyr "mutate"
#' @importFrom dplyr "bind_rows"
#' @importFrom plot3D "perspbox"
#' @importFrom plot3D "trans3D"

AxisLabels3D <- ggproto("AxisLabels3D", Stat,
                        
                        compute_group = function(data, scales, theta=0, phi=0 ) {
                          
                          pmat = plot3D::perspbox(z=diag(2), plot=F, theta=theta, phi=phi)
                          
                          XY = plot3D::trans3D(
                            x = c(1,.1,0,0,0,0),
                            y = c(0,0,1,.1,0,0),
                            z = c(0,0,0,0,1,.1),
                            pmat = pmat) %>%
                            data.frame()
                          
                          XY = sapply(1:nrow(XY), function(i) {
                            XY_i = XY[i,]
                            x = XY_i$x
                            y = XY_i$y
                            
                            XY_i$hjust = ifelse(x > 0, -.1, 1.1)
                            XY_i$vjust = ifelse(y > 0, 1.1, -.1)
                            XY_i
                          }, simplify=F) %>%
                            bind_rows()
                          
                          df = XY
                          df$label = c(max(data$x), min(data$x), max(data$y), min(data$y), max(data$z), min(data$z))
                          
                          df
                        },
                        
                        required_aes = c("x", "y", "z")
)

#' 3D Axis Numbering
#'
#' This function adds 3D axis numbering to ggplot2 plots.
#'
#' @param theta The azimuthal direction in degrees.
#' @param phi The colatitude in degrees.
#' @param ... Arguements passed on to layer.
#' These are often aesthetics, used to set an
#' aesthetic to a fixed value, like color = "red" or size = 3.
#' @export
axis_labs_3D <- function(mapping = aes(group=1), data = NULL, geom = "text",
                         position = "identity", na.rm = FALSE, show.legend = NA,
                         inherit.aes = TRUE, ...) {
  layer(
    stat = AxisLabels3D, data = data, mapping = mapping, geom = geom,
    position = position, show.legend = FALSE, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

#' @importFrom magrittr "%>%"
#' @importFrom scales "rescale"
#' @importFrom dplyr "mutate"
#' @importFrom dplyr "bind_rows"
#' @importFrom plot3D "perspbox"
#' @importFrom plot3D "trans3D"

Label3D <- ggproto("Label3D", Stat,
                   
                   compute_group = function(data, scales, theta=0, phi=0 , labs=c("x-axis", "y-axis", "z-axis")) {
                     
                     pmat = plot3D::perspbox(z=diag(2), plot=F, theta=theta, phi=phi)
                     
                     XY = plot3D::trans3D(
                       x = c(1,0,0),
                       y = c(0,1,0),
                       z = c(0,0,1),
                       pmat = pmat) %>%
                       data.frame()
                     
                     df = XY
                     df$label = labs
                     
                     df
                   },
                   
                   required_aes = c("x", "y", "z")
)

#' 3D Axis Labels
#'
#' This function adds 3D axis labels to ggplot2 plots.
#'
#' @param theta The azimuthal direction in degrees.
#' @param phi The colatitude in degrees.
#' @param label The labels to add. A vector of three where the first
#' element is x, the second is y, and the third is z.
#' @param ... Arguements passed on to layer.
#' These are often aesthetics, used to set an
#' aesthetic to a fixed value, like color = "red" or size = 3.
#' @export
labs_3D <- function(mapping = aes(group=1), data = NULL, geom = "text",
                    position = "identity", na.rm = FALSE, show.legend = NA,
                    inherit.aes = TRUE, ...) {
  layer(
    stat = Label3D, data = data, mapping = mapping, geom = geom,
    position = position, show.legend = FALSE, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

#' @importFrom magrittr "%>%"
#' @importFrom scales "rescale"
#' @importFrom dplyr "mutate"
#' @importFrom dplyr "bind_rows"
#' @importFrom plot3D "perspbox"
#' @importFrom plot3D "trans3D"

Stat3D <- ggproto("Stat3D", Stat,
                  
                  setup_params = function(data, params) {
                    
                    params$xrange <- range(data$x)
                    params$yrange <- range(data$y)
                    params$zrange <- range(data$z)
                    
                    params
                  },
                  
                  compute_group = function(data, scales, theta=0, phi=0 , xrange=c(0,1), yrange=c(0,1), zrange=c(0,1)) {
                    
                    data = data %>%
                      mutate(
                        x = scales::rescale(x, from=xrange, to=c(0,1)),
                        y = scales::rescale(y, from=yrange, to=c(0,1)),
                        z = scales::rescale(z, from=zrange, to=c(0,1)))
                    
                    pmat = plot3D::perspbox(z=diag(2), plot=F, theta=theta, phi=phi)
                    
                    XY = plot3D::trans3D(
                      x = data$x,
                      y = data$y,
                      z = data$z,
                      pmat = pmat) %>%
                      data.frame()
                    
                    data$x = XY$x
                    data$y = XY$y
                    
                    data
                  },
                  
                  required_aes = c("x", "y", "z")
)

#' Draw 3D Geoms
#'
#' This function adds 3D geoms such as points and paths to a ggplot2 plot.
#'
#' @param theta The azimuthal direction in degrees.
#' @param phi The colatitude in degrees.
#' @param geom The geom type to use *ie. "point", "path", "line"*
#' @param ... Arguements passed on to layer.
#' These are often aesthetics, used to set an
#' aesthetic to a fixed value, like color = "red" or size = 3.
#' @export
stat_3D <- function(mapping = NULL, data = NULL, geom = "point",
                    position = "identity", na.rm = FALSE, show.legend = NA,
                    inherit.aes = TRUE, ...) {
  layer(
    stat = Stat3D, data = data, mapping = mapping, geom = geom,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}

#' @importFrom magrittr "%>%"
#' @importFrom scales "rescale"
#' @importFrom dplyr "mutate"
#' @importFrom dplyr "bind_rows"
#' @importFrom plot3D "perspbox"
#' @importFrom plot3D "trans3D"

StatWireframe <- ggproto("StatWireframe", Stat,
                         
                         setup_params = function(data, params) {
                           
                           params$xrange <- range(data$x)
                           params$yrange <- range(data$y)
                           params$zrange <- range(data$z)
                           
                           params
                         },
                         
                         compute_group = function(data, scales, theta=0, phi=0 , xrange=c(0,1), yrange=c(0,1), zrange=c(0,1)) {
                           
                           data = data %>%
                             mutate(
                               x = scales::rescale(x, from=xrange, to=c(0,1)),
                               y = scales::rescale(y, from=yrange, to=c(0,1)),
                               z = scales::rescale(z, from=zrange, to=c(0,1)))
                           
                           pmat = plot3D::perspbox(z=diag(2), plot=F, theta=theta, phi=phi)
                           
                           x_wires = sapply(unique(data$x), function(xi) {
                             df_xi = dplyr::filter(data, x == xi) %>%
                               arrange(x, y)
                             XY <- plot3D::trans3D(
                               x = df_xi$x,
                               y = df_xi$y,
                               z = df_xi$z,
                               pmat = pmat) %>%
                               data.frame() %>%
                               mutate(z = df_xi$z)
                             XY = rbind(c(NA, NA, NA), XY, c(NA, NA, NA))
                             XY
                           }, simplify=F) %>%
                             bind_rows()
                           
                           y_wires = sapply(unique(data$y), function(yi) {
                             df_yi = dplyr::filter(data, y == yi) %>%
                               arrange(x, y)
                             XY <- plot3D::trans3D(
                               x = df_yi$x,
                               y = df_yi$y,
                               z = df_yi$z,
                               pmat = pmat) %>%
                               data.frame() %>%
                               mutate(z = df_yi$z)
                             XY = rbind(c(NA, NA, NA), XY, c(NA, NA, NA))
                             XY
                           }, simplify=F) %>%
                             bind_rows()
                           
                           df = bind_rows(x_wires, y_wires)
                           df
                         },
                         
                         required_aes = c("x", "y", "z")
)

#' Wireframe Plot
#'
#' This function adds a 3D wireframe to a ggplot2 plot.
#'
#' @param theta The azimuthal direction in degrees.
#' @param phi The colatitude in degrees.
#' @param ... Arguements passed on to layer.
#' These are often aesthetics, used to set an
#' aesthetic to a fixed value, like color = "red" or size = 3.
#' @export
stat_wireframe <- function(mapping = NULL, data = NULL, geom = "path",
                           position = "identity", na.rm = FALSE, show.legend = NA,
                           inherit.aes = TRUE, ...) {
  layer(
    stat = StatWireframe, data = data, mapping = mapping, geom = geom,
    position = position, show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
  )
}