Merge pull request #196 from natverse/fix/ngl_annotation_cols

Fix/ngl annotation cols

R/autosyn.R

@@ -46,7 +46,7 @@ flywireids_tbl <- function(local = NULL) {
 ntpredictions_tbl <- function(local = NULL) {
   p=local_or_google("synister_fafb_whole_volume_v3_t11.db", local = local)
   if(isFALSE(p) || is.null(p)){
-    warning('using transmitter predictions v2, but v3 should be available as: synister_fafb_whole_volume_v3_t11')
+    warn_hourly('using transmitter predictions v2, but v3 should be available as: synister_fafb_whole_volume_v3_t11')
     p=local_or_google("20191211_fafbv14_buhmann2019_li20190805_nt20201223.db", local = local)
     memo_tbl(p, "predictions2")
   }else{

R/ids.R

@@ -274,11 +274,14 @@ id2char <- function(x) {
 #' @description \code{ngl_layers} extract the neuroglancer layers with
 #'   convenience options for selecting layers by characteristics such as
 #'   visibility, type etc.
-#' @param x a neuroglancer scene object (see \code{\link{ngscene}})
+#' @param x a neuroglancer scene object (see \code{\link{ngscene}}) or an
+#'   existing \code{nglayers} object (which you probably want to subset).
 #' @param subset an expression (evaluated in the style of subset.dataframe)
 #'   which defined
+#' @return A list of layers with additional class \code{nglayers}
 #'
 #' @export
+#' @aliases nglayers
 #'
 #' @seealso \code{\link{ngl_decode_scene}}, \code{\link{ngl_layers}},
 #'   \code{\link{ngl_segments}}, \code{\link{ngl_encode_url}}
@@ -299,12 +302,16 @@ id2char <- function(x) {
 #' str(ngl_layers(sc, type %in% c("image", "segmentation_with_graph")))
 #' }
 ngl_layers <- function(x, subset=NULL) {
-  if(!is.ngscene(x))
-    stop("Unable to extract layer information from ", deparse(substitute(x)),
-         " as it is not an ngscene object!")
+  layers <- if(inherits(x, 'nglayers')) x
+  else {
+    if(!is.ngscene(x))
+      stop("Unable to extract layer information from ", deparse(substitute(x)),
+           " as it is not an ngscene object!")
+    layers=x[['layers']]
+    class(layers)=c("nglayers", "list")
+    layers
+  }
 
-  layers=x[['layers']]
-  class(layers)=c("nglayers", "list")
   # record the layers as names for ease of manipulation in R
   # these attributes should be stripped off by ngl_encode_url
   df <- ngl_layer_summary(layers)

R/ng-annotations.R

@@ -1,7 +1,8 @@
 #' Extract annotations from a neuroglancer scene into a dataframe
 #'
 #' @param x A neuroglancer scene or URL (passed to
-#'   \code{\link{ngl_decode_scene}} as necessary)
+#'   \code{\link{ngl_decode_scene}} as necessary) or a neuroglancer layers
+#'   (\code{\link{nglayers}}) extracted from such a scene.
 #' @param layer Optional index vector specifying the layers within a scene from
 #'   which to extract annotations. It is probably safest to use a character
 #'   vector of layer names (what appears in neuroglancer). When missing all
@@ -11,8 +12,10 @@
 #' @param points What to do with point coordinates.
 #'
 #' @return A data.frame with columns defined by the contents of the annotation
-#'   layer and the \code{types}/\code{points} arguments. Additional attributes are stored
+#'   layer and the \code{types}/\code{points} arguments. Additional annotation
+#'   features are stored as attributes on the data.frame.
 #' @export
+#' @seealso \code{\link{ngl_annotation_layers}} to make new annotation layers
 #'
 #' @examples
 #' \donttest{
@@ -24,7 +27,7 @@ ngl_annotations <- function(x, layer=NULL, types=c("point", "line"),
                          points=c('collapse', 'expand', 'list')) {
   points=match.arg(points)
   types=match.arg(types, several.ok = TRUE)
-  x=ngl_decode_scene(x)
+  x <- if(inherits(x, 'nglayers')) x else ngl_decode_scene(x)
   anns <- if(is.null(layer)) {
     ngl_layers(x, type=="annotation")
   } else {
@@ -125,8 +128,8 @@ normalise_cave_annotation_df <- function(x, colpal=NULL, rawcoords=NA) {
     } else if(nlayers>1 && ncols>1) {
       tt=table(x$layer, x$col)
       stopifnot(isTRUE(dim(tt)[1]==dim(tt)[2]))
-      noffdiag=sum(tt) - diag(tt)
-      if(noffdiag>0)
+      ncols_layer=rowSums(tt>0)
+      if(any(ncols_layer>1))
         stop("Discrepancy between layer and colour specification. Make sure they match or provide only one!")
     }
   } else if("layer" %in% cx && !is.null(colpal)) {
@@ -141,49 +144,102 @@ normalise_cave_annotation_df <- function(x, colpal=NULL, rawcoords=NA) {
       warning("Missing levels in colour palette; setting to white!")
     }
   } else if("col" %in% cx) {
-    ncols=length(unique(x$col))
+    ucols=unique(x$col)
+    ncols=length(ucols)
     x$layer <- if(ncols==1) 'annotation'
-    else paste('annotation', seq_len(ncols))
+    else paste('annotation', match(x$col, ucols))
   } else {
-    x$layer="annotations"
+    if(!"layer" %in% colnames(x))
+      x$layer="annotations"
   }
   selcols=intersect(c("layer", "point", "segments", "col"),
                    colnames(x))
   x[selcols]
 }
 
 
-
 #' Construct one or more neuroglancer annotation layers
 #'
-#' @details The \code{ann} arguments
+#' @details If you supply a dataframe for the \code{ann} argument then you can
+#'   have columns called \itemize{
+#'
+#'   \item \code{point} or \code{position} or \code{pt_position} to
+#'   define the position. This should contain x,y,z coordinates formatted as a
+#'   character vector (\code{\link{xyzmatrix2str}}) or a \code{list} of
+#'   \code{numeric} \code{vector}s (\code{\link{xyzmatrix2list}}).
+#'
+#'   \item \code{layer} optionally name a layer for each point
+#'
+#'   \item \code{col} optionally specify a color for each point.
+#'
+#'   \item \code{root_id} optionally specify a supervoxel id that the point maps onto
+#'
+#'   \item \code{supervoxel_id} optionally specify a supervoxel id that the point maps onto
+#'
+#'   }
+#'
+#'   Neuroglancer only allows one colour per annotation layer, so if you specify
+#'   both \code{col} and \code{layer} they must be consistent.
+#'
+#'   Neuroglancer annotations are specified in raw coordinates. Although this
+#'   function can try to convert nm coordinates to raw, this will only work for
+#'   points in the brain space defined by the current fafb segmentation (see
+#'   \code{\link{choose_segmentation}}). For this reason you should used
+#'   \code{rawcoords=FALSE} and convert coordinates yourself if you are working
+#'   with other brain spaces.
 #' @param ann An annotation dataframe (see details) or any object containing 3D
 #'   vertices from which \code{\link{xyzmatrix}} can successfully extract
 #'   points.
 #' @param rawcoords Whether points have been provided in raw (voxel) coordinates
 #'   or in calibrated (nm) positions. The default of \code{NA} will try to infer
-#'   this based on the coordinate values.
-#' @param colpal A function or character vector of colour names that will be
-#'   used to set the colour for each layer.
+#'   this based on the coordinate values but see details for limitations.
+#'
+#' @param colpal A function or named character vector of colours that will be
+#'   used to set the colour for each layer. Colours should be specified by name
+#'   or hex format.
 #'
 #' @return A list of additional class \code{nglayers} which can be added to an
 #'   \code{ngscene} object as produced by \code{\link{ngl_decode_scene}}.
 #' @export
-#' @seealso \code{\link{ngl_annotations}}
+#' @seealso \code{\link{ngl_annotations}} to extract annotations from a scene.
 #' @examples
 #' \dontrun{
+#' ## as an example label proofread neurons by institution
 #' psp=flywire_cave_query('proofreading_status_public_v1')
 #' fwusers=googlesheets4::read_sheet('1G0zqA5DTrfd-a2LuebV4kcqNfl4q1ehlzHBrwT6ZMoc')
-#' psp2=left_join(psp, fwusers, by=c("user_id"="id"))
+#' psp2=dplyr::left_join(psp, fwusers, by=c("user_id"="id"))
 #' psp2$layer=psp2$institution
-#' al=ngl_annotation_layers(psp2[c("pt_position", "layer")])
-#'
+#' # sample 3000 neurons to be a more manageable as an example.
+#' psp2s=dplyr::slice_sample(psp2, n=3000) %>%
+#'   dplyr::filter(!is.na(layer))
+#' # the layers will be rainbow coloured
+#' al=ngl_annotation_layers(psp2s[c("pt_position", "layer")], colpal=rainbow)
+#' # make a blank scene
+#' sc=ngl_blank_scene()
+#' # or decode a URL that you've copied from your browser
+#' sc=ngl_decode_scene(clipr::read_clip())
+#' # and the add your annotations as new layer(s) to that scene
+#' sc2=sc+al
+#' # and make a URL
+#' u=as.character(sc2)
+#' # and copy that to clipboard
+#' clipr::write_clip(u)
+#' # ... or open directly in your browser
+#' browseURL(u)
+#' # It is a good idea to shorten when there are many annotations.
+#' # This will load much faster in the browser and be easier to work with
+#' su=flywire_shortenurl(u)
+#' browseURL(su)
 #' }
 ngl_annotation_layers <- function(ann, rawcoords=NA, colpal=NULL) {
   if(!is.data.frame(ann)) ann=data.frame(point=xyzmatrix2str(ann))
   stopifnot(is.data.frame(ann))
   ann=normalise_cave_annotation_df(ann, colpal=colpal, rawcoords=rawcoords)
   uls=unique(ann$layer)
+  if(any(is.na(uls))) {
+    warning("Some annotation rows have an `NA` layer - these will be dropped!")
+    uls=na.omit(uls)
+  }
   layers=list()
   for(l in uls) {
     annl=ann[ann$layer==l,,drop=F]

R/urls.R

@@ -345,12 +345,17 @@ ngl_add_colours <- function(x, colours, layer=NULL) {
 }
 
 # utility function to convert R colours
-col2hex <- function(x) {
+col2hex <- function(x, tolower=TRUE) {
   if(is.list(x)) {
-    return(sapply(x, col2hex, simplify = F))
+    return(sapply(x, col2hex, tolower=tolower, simplify = F))
   }
   hexmatrix=col2rgb(x)
-  rgb(hexmatrix[1,], hexmatrix[2,], hexmatrix[3,], maxColorValue = 255)
+  hex=rgb(hexmatrix[1,], hexmatrix[2,], hexmatrix[3,], maxColorValue = 255)
+  if(tolower)
+    hex=tolower(hex)
+  # add back names (if there were any)
+  names(hex)=names(x)
+  hex
 }