R/open_fafb.R

In jefferis/elmr: Support for working with light and electron microscopy fly brain data

#' Generate URLs to open FAFB CATMAID in browser at a given XYZ location
#'
#' @details Note that the default behaviour is that if object \code{x} contains
#'   exactly one point then a single URL will be generated and by default
#'   CATMAID will be opened immediately at that location. If there is more than
#'   1 point, by default the function will stop and wait for the user to make an
#'   interactive selection in a \code{rgl} window.
#'
#'   You can control this behaviour by using the \code{open} and \code{rowwise}
#'   arguments. When \code{open=FALSE}, then the URLs will be returned but not
#'   opened in a web browser. If \code{rowwise=TRUE} (i.e. multiple URLs are
#'   being generated) then \code{open} will be set to \code{FALSE}.
#'
#'   When \code{rowwise=TRUE} each point in \code{x} is converted to a separate
#'   URL. As a special case, if \code{x} is a data.frame generated by
#'   \code{catmaid_get_treenodes_detail} then URLs will be generated for every
#'   row (i.e. each treenode). See examples for details.
#' @param x A numeric vector or any object compatible with
#'   \code{\link[nat]{xyzmatrix}} (see details)
#' @param s Optional selection function of the type returned by
#'   \code{\link[rgl]{select3d}}
#' @param mirror Whether to mirror the point to the opposite side of the brain
#' @param rowwise When \code{rowwise=TRUE} each point in \code{x} is converted
#'   to a separate URL.
#' @param sample The template brain space associated with the coordinates in
#'   \code{x}
#' @param open Whether to open the url in the browser or simply return it.
#'   Defaults to \code{TRUE} when R is running in interactive mode.
#' @param zoom The CATMAID zoom factor (defaults to 1)
#' @param active_skeleton_id,active_node_id Set highlighted skeleton and node in
#'   CATMAID.
#' @param server Optional string or \code{\link{catmaid_connection}} that
#'   specifies the server URL (otherwise a hardcoded URL will be used).
#'@param url a CATMAID URL.
#' @param ... Additional arguments to be added to URL or sent to \code{mirror_brain}.
#' @export
#' @importFrom utils browseURL
#' @importFrom nat xyzmatrix
#' @seealso \code{\link{xform_brain}},
#'   \code{\link{catmaid_get_treenodes_detail}}
#' @examples
#' open_fafb(c(316, 143, 26), sample=JFRC2013, open=FALSE)
#' library(nat)
#' \dontrun{
#' open3d()
#' plot3d(kcs20)
#' # waits for user to draw a selection rectangle
#' open_fafb(kcs20, sample=FCWB)
#' # same but mirrors selected points to opposite hemisphere
#' open_fafb(kcs20, sample=FCWB, mirror=TRUE)
#'
#' open_fafb(kcs20, sample=FCWB, server="https://bigbrain.org/tracing")
#' # Uses last CATMAID connection to specify URL to open
#' open_fafb(kcs20, sample=FCWB, server=catmaid_login())
#' }
#'
#' \donttest{
#' # make one URL for each row of the input
#' open_fafb(matrix(runif(n=6, max=1000), ncol = 3), rowwise=TRUE)
#' }
#'
#' \donttest{
#' ## Special case using catmaid_get_treenodes_detail() as input
#' # fetch a neuron and extract the node ids for a given tag
#' n=read.neuron.catmaid(16, conn = catmaid::vfbcatmaid('fafb'))
#' tagged = n$tags[['TODO']]
#' tagged_details <- catmaid_get_treenodes_detail(tagged)
#' # now find FAFB URLs
#' tagged_details$url <- open_fafb(tagged_details)
#' # take a look at results
#' head(tagged_details)
#' }
#'
#' \dontrun{
#' # copy results to clipboard e.g. to paste into a spreadsheet
#' library(clipr)
#' write_clip(tagged_details)
#' }
open_fafb<-function(x, s=rgl::select3d(), mirror=FALSE, sample=elmr::FAFB,
                    rowwise=NA, open=interactive() & !rowwise, zoom=1,
                    active_skeleton_id=NULL, active_node_id=NULL, server=NULL,
                    ...) {
  # special case, looks like results of catmaid_get_treenodes_detail
  if(is.data.frame(x) && all(c("treenode_id","skid", "x", "y", "z") %in% names(x))) {
    # looks like a data frame from catmaid_get_treenodes_detail
    if(is.na(rowwise)) rowwise=TRUE
    xyz=xyzmatrix(x)
    if(is.null(active_skeleton_id))
      active_skeleton_id = x[['skid']]
    if(is.null(active_node_id))
      active_node_id = x[['treenode_id']]
  }
  if(is.na(rowwise)) {
    if(length(active_skeleton_id)>1 || length(active_node_id)>1) rowwise=TRUE
    else rowwise=FALSE
  }
  if(is.vector(x, mode='numeric') && length(x)==3 ){
    xyz=matrix(x, ncol=3)
  } else {
    xyz=xyzmatrix(x)
    if(nrow(xyz)>1 && !rowwise){
      # calculate centroid of points inside selection
      xyz=colMeans(xyz[s(xyz),, drop=F])
      xyz=matrix(xyz, ncol=3)
    }
  }
  if(mirror)
    xyz=mirror_brain(xyz, sample)

  csample=as.character(sample)
  if(substr(csample, 1, 4)!="FAFB"){
    xyz=xform_brain(xyz, sample = sample, reference = elmr::FAFB)
    csample=as.character(elmr::FAFB)
  }

  server_url <- if (isTRUE(is.null(server))) {
    fafb.version=substr(csample,5,nchar(csample))
    paste0("https://neuropil.janelia.org/tracing/fafb/v", fafb.version)
  } else {
    if(!inherits(server, "catmaid_connection") && !is.character(server))
      stop("server must be a string or a catmaid_connection object")
    if(inherits(server, "catmaid_connection")) server[['server']] else server
  }
  last_char <- function(s) substr(s, nchar(s), nchar(s))
  if(!isTRUE(last_char(server_url)=="/"))
    server_url=paste0(server_url, "/")
  # round to nearest integer
  xyz <- round(xyz)
  url=sprintf("%s?pid=1&zp=%d&yp=%d&xp=%d&tool=tracingtool&sid0=5&s0=%f",
              server_url, xyz[,3], xyz[,2], xyz[,1], zoom)
  apl=pairlist(...)
  apl$active_skeleton_id=active_skeleton_id
  apl$active_node_id=active_node_id
  if(length(apl)){
    # interpret as extra params
    # first make a list with an entry for each param
    varlist = mapply(paste0, names(apl), "=", apl, SIMPLIFY = FALSE)

    # check that we have sensible lengths for all the extra arguments
    nurls=length(url)
    badlengths=setdiff(sapply(varlist, length),
                       c(nurls, 1))
    if(length(badlengths)) {
      stop(
        "Some argument lengths (",
        paste(badlengths, collapse = ','),
        ") do not match the number of points (",
        nurls,
        ")"
      )
    }
    # then paste together matching elements from each param, recylcling
    # singletons as necessary
    urltails = do.call(paste, c(varlist, sep = "&"))
    # finally build the complete url
    url = paste0(url, "&", urltails)
  }

  if(open){
    browseURL(url)
    invisible(url)
  } else {
    url
  }
}

#' @export
#' @rdname open_fafb
mirror_fafb_url <- function(url, ...){
  if(length(url)>1){
    url.m = sapply(url, mirror_fafb_url, ...)
  }else{
    x = gsub(".*xp=|&tool.*","",url)
    y = gsub(".*yp=|&xp.*","",url)
    z = gsub(".*zp=|&yp.*","",url)
    xyz = t(matrix(as.numeric(c(x,y,z))))
    xyz.jfrc2 = xform_brain(xyz, sample = elmr::FAFB, reference = nat.flybrains::JFRC2, ...)
    xyz.jfrc2.m = mirror_brain(x=xyz.jfrc2,brain=nat.flybrains::JFRC2, ...)
    xyz.m = xform_brain(xyz.jfrc2.m, reference = elmr::FAFB, sample = nat.flybrains::JFRC2, ...)
    url.m = gsub(x,xyz.m[1,1],url)
    url.m = gsub(y,xyz.m[1,2],url.m)
    url.m = gsub(z,xyz.m[1,3],url.m)
    url.m = gsub("&active_.*","",url.m)
  }
  url.m
}