R/mouse_ccf_meshes.R

In AllenInstitute/cocoframer: COmmon COordinate FRAMEwork in R

#' Read a .obj file to get a rgl-compatible mesh object
#'
#' @param obj A character object with the location of a .obj file.
#' @param material The rgl material to use for the mesh. Default is "gray". For details, see ?rgl.material.
#' @param invert_y Logical. Whether to flip the object in the y-dimensions. This is useful for AIBS mesh objects. Default is TRUE.
#' @param yrange Length 2 numeric vector indicating the range to use for inversion. Default is c(0,8000).
#'
#' @return a list object with class mesh3d and shape3d.
#' @export
#'
obj_to_mesh <- function(obj,
                        material = "gray",
                        invert_y = TRUE,
                        yrange = c(0,8000)) {

  obj_lines <- readLines(obj)

  vertex_lines <- obj_lines[grepl("^v ",obj_lines)]
  vertex_values <- as.numeric(unlist(strsplit(sub("v ","",vertex_lines)," ")))
  vertex_matrix <- t(matrix(vertex_values, nrow = length(vertex_lines), byrow = TRUE))

  if(invert_y) {
    midpoint <- (yrange[1] + yrange[2]) / 2
    vertex_matrix[2,] <- vertex_matrix[2,] + 2 * (midpoint - vertex_matrix[2,])
  }

  vertex_matrix <- rbind(vertex_matrix, rep(1, ncol(vertex_matrix)))


  face_lines <- obj_lines[grepl("^f ",obj_lines)]
  face_values <- as.integer(sub("//.+","",unlist(strsplit(sub("f ","",face_lines)," "))))
  face_matrix <- t(matrix(face_values, nrow = length(face_lines), byrow = TRUE))

  mesh <- list(vb = vertex_matrix, it = face_matrix, primitivetype = "triangle", material = material)
  class(mesh) <- c("mesh3d", "shape3d")

  mesh
}

#' Save a mesh object to a zip file for later use
#'
#' This is currently only intended to work with triangular faces.
#'
#' This converts the vertex positions (vb) and face indexes (it) to vectors and
#' stores them compactly as zipped binary files.
#'
#' The first value in each file is a 32-bit integer specifying the number of vertexes or positions.
#'
#' No material information is retained.
#'
#' Note that new data will be appended to an existing .zip file. This allows many
#' meshes to be stored together.
#'
#' @param mesh The mesh object to store.
#' @param mesh_name A character object specifying the mesh name, which will be used for file names.
#' @param zip_file The zip file to use as output.
#'
#' @export
#'
save_rgl_mesh_zip <- function(mesh,
                              mesh_name,
                              zip_file) {

  vb_vector <- as.vector(mesh$vb[1:3,])
  it_vector <- as.vector(mesh$it)

  out_vb_file <- paste0("vb_",mesh_name, ".num")
  out_it_file <- paste0("it_",mesh_name, ".int")

  temp_loc <- tempdir()

  out_vb <- file(file.path(temp_loc, out_vb_file), open = "wb")
  out_it <- file(file.path(temp_loc, out_it_file), open = "wb")

  writeBin(as.integer(length(vb_vector) / 3), out_vb)
  writeBin(as.integer(length(it_vector) / 3), out_it)

  writeBin(vb_vector, out_vb)
  writeBin(it_vector, out_it)

  close(out_vb)
  close(out_it)

  zip(zip_file, c(file.path(temp_loc, out_vb_file),
                  file.path(temp_loc, out_it_file)),
      extras = "-j")

  file.remove(file.path(temp_loc, out_vb_file))
  file.remove(file.path(temp_loc, out_it_file))

}

#' Read a mesh object from a zip file generated by save_rgl_mesh_zip()
#'
#' This is currently only intended to work with triangular faces.
#'
#' This reverses the proccessing in save_rgl_mesh_zip() to rebuild the mesh object
#' from binary vectors.
#'
#' If you're looking for a simple way to get a brain structure, use ccf_2017_mesh, which wraps this
#' function, and retrieves a mesh that's included in this package.
#'
#' @param mesh_name A character object specifying the mesh name, which will be used for file names.
#' @param zip_file The zip file containing vectorized meshes.
#' @param material The rgl material to use for the mesh. Default is "gray". For details, see ?rgl.material.
#'
#' @return a list object with class mesh3d and shape3d.
#' @export
#'
#' @examples
#' mesh_store <- system.file("extdata", "ccf_2017_meshes.zip", package = "cocoframer")
#' structure_id <- mba_structure_id(acronym = "MOp")
#' MOp_mesh <- read_rgl_mesh(structure_id,
#'                           zip_file = mesh_store)
read_rgl_mesh_zip <- function(mesh_name,
                              zip_file,
                              material = "gray") {

  vb_file <- paste0("vb_", mesh_name, ".num")
  it_file <- paste0("it_", mesh_name, ".int")

  in_vb <- unz(zip_file, vb_file, open = "rb")
  in_it <- unz(zip_file, it_file, open = "rb")

  n_vb <- readBin(in_vb, "integer", n = 1) * 3
  n_it <- readBin(in_it, "integer", n = 1) * 3

  vb_vector <- readBin(in_vb, "numeric", n = n_vb)
  it_vector <- readBin(in_it, "integer", n = n_it)

  close(in_vb)
  close(in_it)

  vb_mat <- matrix(vb_vector, nrow = 3)
  it_mat <- matrix(it_vector, nrow = 3)

  vb_mat <- rbind(vb_mat, rep(1, ncol(vb_mat)))

  mesh <- list(vb = vb_mat, it = it_mat, primitivetype = "triangle", material = material)
  class(mesh) <- c("mesh3d", "shape3d")

  mesh

}

#' Retrieve a CCF 2017 mesh from the cocoframer package
#'
#' Must provide either an acronym or a structure_id.
#'
#' @param acronym The structure acronym to retrieve. Default is NULL.
#' @param structure_id The structure_id to retrieve. Defualt is NULL.
#' @param material The rgl material to apply to the mesh. Default is NULL, which uses the ABA ontology colorset.
#' See ?rgl.material for details and additional options.
#'
#' @return a 3D mesh object for the selected structure
#' @export
#'
#' @examples
#' BLA_mesh <- ccf_2017_mesh(acronym = "BLA")
ccf_2017_mesh <- function(acronym = NULL,
                          structure_id = NULL,
                          material = NULL) {

  if(is.null(acronym) & is.null(structure_id)) {
    stop("Must provide either an acronym or a structure_id to retrieve a mesh.")
  } else if(!is.null(acronym)) {
    structure_id <- mba_structure_id(acronym)
  }

  mesh_store <- system.file("extdata", "ccf_2017_meshes.zip", package = "cocoframer")

  if(is.null(material)) {
    if(acronym == "root") {
      material <- list(color = "gray")
    } else {
      material <- list(color = ccf_2017_color(structure_id = structure_id))
    }
  }

  read_rgl_mesh_zip(mesh_name = structure_id,
                    zip_file = mesh_store,
                    material = material)
}

#' Retrieve a set of CCF 2017 colors
#'
#' Must provide either acronym(s) or a structure_id(s).
#'
#' @param acronym The structure acronym(s) to retrieve. Default is NULL.
#' @param structure_id The structure_id(s) to retrieve. Defualt is NULL.
#'
#' @return a vector of color hex values prefixed with "#".
#' @export
#'
#' @examples
#' BLA_mesh <- ccf_2017_color(acronym = "BLA")
ccf_2017_color <- function(acronym = NULL,
                          structure_id = NULL) {

  if(is.null(acronym) & is.null(structure_id)) {
    stop("Must provide either an acronym or a structure_id to retrieve a color.")
  } else if(!is.null(acronym)) {
    structure_id <- mba_structure_id(acronym)
  }

  id_table <- read.csv(system.file("extdata", "mba_structure_id_to_acronym.csv",
                                   package = "cocoframer"),
                       stringsAsFactors = FALSE)

  id_table$color[match(structure_id, id_table$id)]
}