Merge pull request #63 from mandymejia/16.0

16.0

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: ciftiTools
 Type: Package
 Title: Tools for Reading, Writing, Viewing and Manipulating CIFTI Files
-Version: 0.15.1
+Version: 0.16.1
 Authors@R: c(
     person(given = "Amanda",
            family = "Mejia",
@@ -56,6 +56,6 @@ Suggests:
     png,
     testthat (>= 3.0.0)
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 URL: https://github.com/mandymejia/ciftiTools
 BugReports: https://github.com/mandymejia/ciftiTools/issues

NAMESPACE

@@ -55,7 +55,9 @@ export(make_surf)
 export(mask_surf)
 export(merge_xifti)
 export(move_from_mwall)
+export(move_from_submask)
 export(move_to_mwall)
+export(move_to_submask)
 export(newdata_xifti)
 export(parc_add_subcortex)
 export(parc_borders)

NEWS.md

@@ -1,3 +1,14 @@
+# 16.1
+
+* `move_to_submask` and `move_from_submask`
+* add support for writing older xiftis w/o "Other" level in sub labels
+* fix subcortex bugs
+
+# 15.0
+
+* Make default of `read_cifti` all brain structures, instead of left and right cortex only
+* add "Other" to subcortex levels
+
 # 14.0
 
 Minor fixes and improvements.

R/fix_xifti.R

@@ -3,7 +3,8 @@
 #' Make adjustments to a putative \code{"xifti"} so that it is valid. Each
 #'  adjustment is reported.
 #' 
-#' Right now it only coerces the data to numeric matrices.
+#' Right now it: coerces the data to numeric matrices; adds the
+#'  "Other" level to the subcortex labels.
 #' 
 #' @inheritParams xifti_Param
 #' @param verbose Report each adjustment? Default: \code{TRUE}
@@ -13,6 +14,7 @@
 #' 
 fix_xifti <- function(xifti, verbose=TRUE) {
 
+  # Coerce the data to numeric matrices. 
   bs <- names(xifti$data)[!vapply(xifti$data, is.null, FALSE)]
   for (b in bs) {
     if (!is.matrix(xifti$data[[b]])) {
@@ -25,5 +27,16 @@ fix_xifti <- function(xifti, verbose=TRUE) {
     }
   }
 
+  # Add "Other" level to subcortex labels. 
+  if (!is.null(xifti$data$subcort)) {
+    sub_levs <- levels(xifti$meta$subcort$labels)
+    if (length(sub_levs) == 21 && all(sub_levs == substructure_table()$ciftiTools_Name[seq(21)])) {
+      xifti$meta$subcort$labels <- factor(
+        xifti$meta$subcort$labels,
+        levels = substructure_table()$ciftiTools_Name
+      )
+    }
+  }
+
   xifti
 }

R/make_xifti_components.R

@@ -442,11 +442,13 @@ make_subcort <- function(
     stopifnot(all(labs %in% c(0, seq(3, 22))))
     labs <- sub_table$Original_Name[labs]
   }
-  labs <- factor(
-    labs,
-    levels=sub_table$Original_Name,
-    labels=sub_table$ciftiTools_Name
-  )
+  if ((!is.factor(labs)) || (!identical(levels(labs), sub_table$ciftiTools_Name))) {
+    labs <- factor(
+      labs,
+      levels=sub_table$Original_Name,
+      labels=sub_table$ciftiTools_Name
+    )
+  }
   stopifnot(is.subcort_labs(labs))
   stopifnot(!any(is.na(labs)))
 

R/move_submask.R

@@ -0,0 +1,163 @@
+#' Move data locations to the subcortex mask
+#'
+#' Move subcortex data locations with a specific value(s) to the subcortex mask.
+#'
+#' @inheritParams xifti_Param
+#' @param values Values to mask out. Default: \code{NA} and \code{NaN}. Data
+#'  locations in the subcortex that are one of these values (across all columns)
+#'  will be moved to the subcortex mask in the metadata.
+#' @param drop Only used if the \code{"xifti"} has the dlabel intent. Drop the
+#'  key(s) in \code{values} from the label tables, for columns in which they no
+#'  longer exist? Default: \code{FALSE}.
+#'
+#'
+#' @return The \code{"xifti"} with re-organized data and subcortex masks
+#'
+#' @family manipulating xifti
+#'
+#' @export
+#'
+#' @seealso move_from_submask
+move_to_submask <- function(xifti, values=c(NA, NaN), drop=FALSE){
+  stopifnot(is.xifti(xifti))
+  values <- as.numeric(values)
+
+  updated <- FALSE
+
+  mask2 <- !apply(
+    matrix(xifti$data$subcort %in% values, ncol=ncol(xifti)),
+    1, all
+  )
+
+  if (!all(mask2)) {
+    updated <- TRUE
+    if (all(!mask2)) { ciftiTools_warn(paste0("All locations are being removed in the subcortex: errors in other functions may occur.")) }
+    # Update metadata.
+    xifti$meta$subcort$mask[xifti$meta$subcort$mask] <- mask2
+    xifti$meta$subcort$labels <- xifti$meta$subcort$labels[mask2]
+    # Remove from data.
+    xifti$data$subcort <- xifti$data$subcort[mask2,,drop=FALSE]
+  }
+
+  if (!updated) { ciftiTools_warn("No data locations moved."); return(xifti) }
+
+  if (drop) {
+    if (!is.null(xifti$meta$cifti$intent) && xifti$meta$cifti$intent == "3007") {
+      for (ii in seq(ncol(xifti))) {
+        if (any(as.matrix(xifti)[,ii] %in% values)) { next }
+        labtab <- xifti$meta$cifti$labels[[ii]]
+        xifti$meta$cifti$labels[[ii]] <- labtab[!(labtab$Key %in% values),]
+      }
+    } else {
+      ciftiTools_warn("Cannot `drop` labels, because the xifti does not have the dlabel intent.")
+    }
+  }
+
+  if (!is.xifti(xifti)) { stop("Could not make a valid \"xifti\" object.") }
+  xifti
+}
+
+#' Move data locations from subcortex mask
+#'
+#' Move subcortex mask locations into the subcortex data matrix by assigning
+#'  them a specific value (e.g. NA).
+#'
+#' @inheritParams xifti_Param
+#' @param new_mask The new mask, of which the current mask should be a subset.
+#'  (\code{new_mask} should have more \code{TRUE} values.) The new \code{TRUE}
+#'  values will be moved to the subcortex data.
+#' @param value The value to assign the new locations. Default: \code{NA}.
+#' @param label_value The label value to assign the new locations. Default:
+#'  \code{"Other"}.
+#' @param name,RGBA Only used if the \code{"xifti"} has the dlabel intent and
+#'  \code{value} is not an already-existing Key. This is the name to assign to
+#'  the new key for the new locations, as well as a length-four numeric
+#'  vector indicating the red, green, blue, and alpha values for the color to
+#'  assign to the new key. These will be reflected in the updated label table.
+#'  Note that RGBA values must all be in \[0, 1\].
+#'
+#'  Currently, only one name and set of RGBA values are supported, meaning that
+#'  the out-of-mask subcortex locations will have the same Key, name, and color
+#'  across all data columns in the \code{"xifti"}. An error will occur if the 
+#'  Key already exists for some columns but not others.
+#'
+#'  Defaults: \code{"Other"} for \code{"name"} and white with 0 alpha for
+#'  \code{RGBA}.
+#'
+#' @return The \code{"xifti"} with re-organized data and subcortex masks
+#'
+#' @export
+#'
+#' @seealso move_to_submask
+#' @seealso unmask_cortex
+move_from_submask <- function(xifti, new_mask, value=NA, label_value="Other", name="Other", RGBA=c(1,1,1,0)){
+  stopifnot(is.xifti(xifti))
+  value <- as.numeric(value)
+  if (length(value) > 1) {
+    warning("Using the first entry of `value`.")
+    value <- value[1]
+  }
+
+  updated <- FALSE
+
+  old_submask <- xifti$meta$subcort$mask
+  stopifnot(all(new_mask[old_submask])) # `new_mask` should contain all values in `old_submask`
+  mask2 <- old_submask[new_mask]
+  if (any(!mask2)) {
+    updated <- TRUE
+    xifti$data$subcort <- unmask_cortex(xifti$data$subcort, mask2, mwall_fill=value)
+    # Update metadata
+    xifti$meta$subcort$mask <- new_mask
+    stopifnot(label_value %in% levels(xifti$meta$subcort$labels))
+    q <- factor(
+      rep(label_value, sum(new_mask)),
+      levels=levels(xifti$meta$subcort$labels)
+    )
+    q[mask2] <- xifti$meta$subcort$labels
+    xifti$meta$subcort$labels <- q
+  }
+
+  if (!updated) { ciftiTools_warn("No data locations moved."); return(xifti) }
+
+  if (!is.null(xifti$meta$cifti$intent) && xifti$meta$cifti$intent == 3007) {
+    new_key <- vapply(
+      xifti$meta$cifti$labels,
+      function(x){ !(value %in% x$Key) },
+      FALSE
+    )
+    if (any(new_key)) {
+      if (!all(new_key)) {
+        stop(
+          "The replacement `value` is an existing key for labels in some ",
+          "columns, but not others. This is not yet supported. Try choosing ",
+          "a `value` which is not any existing key."
+        )
+      }
+
+      name <- as.character(name)
+      if (length(name) > 1) {
+        warning("Using the first entry of `name`.");
+        name <- name[1]
+      }
+      RGBA <- as.numeric(RGBA)
+      if (length(RGBA) != 4) {
+        stop("RGBA must be a length-4 numeric vector indicating the values for red, green, blue, and alpha.")
+      }
+      if (any(RGBA < 0) || any(RGBA > 1)) {
+        stop("RGBA values must be in [0, 1]. (Not between 0 and 255.)")
+      }
+
+      # Add a row to the label tabel for the new key.
+      for (ii in seq(ncol(xifti))) {
+        labtab <- xifti$meta$cifti$labels[[ii]]
+        labtab <- rbind(labtab, c(value, RGBA))
+        rownames(labtab)[nrow(labtab)] <- name
+        labtab <- labtab[order(labtab$Key),]
+        xifti$meta$cifti$labels[[ii]] <- labtab
+      }
+    }
+  }
+
+  if (!is.xifti(xifti)) { stop("Could not make a valid \"xifti\" object.") }
+  xifti
+}

R/view_xifti_surface.R

@@ -574,9 +574,9 @@ view_xifti_surface.draw_mesh <- function(
 #'  \code{TRUE} borders will be colored in black; provide the name of a different
 #'  color to use that instead. If \code{FALSE} or \code{NULL} (default), do
 #'  not draw borders.
-#' @param shadows Number from 0 (maximum added lighting) to 1 (no added 
-#'  lighting) to control the darkness and extent of shadowing on the 3D surface. 
-#'  Default: \code{1}. Shadows help render the shape of the surface, but can 
+#' @param shadows Number from 0 (maximum added lighting) to 1 (no added
+#'  lighting) to control the darkness and extent of shadowing on the 3D surface.
+#'  Default: \code{1}. Shadows help render the shape of the surface, but can
 #'  be distracting if interpretation of the data depends on small differences in
 #'  brightness along the color scale.
 #' @return If a png or html file(s) were written, the names of the files for

R/write_cifti.R

@@ -26,6 +26,8 @@
 #'
 write_cifti <- function(
   xifti, cifti_fname, surfL_fname=NULL, surfR_fname=NULL, verbose=TRUE) {
+
+  xifti <- fix_xifti(xifti)
   stopifnot(is.xifti(xifti))
 
   # Infer extension from name, and add it to `xifti`.

R/write_nifti.R

@@ -110,7 +110,14 @@ write_subcort_nifti <- function(
   }
 
   # Labels.
-  stopifnot(is.subcort_labs(subcortLabs))
+  ### Add "Other" level for older `xifti` objects. 
+  if (length(levels(subcortLabs)) != length(substructure_table()$ciftiTools_Name)) {
+    subcortLabs <- factor(
+      subcortLabs,
+      levels = substructure_table()$ciftiTools_Name
+    )
+    stopifnot(is.subcort_labs(subcortLabs))
+  }
   subcortLabs <- as.numeric(subcortLabs)
   subcortLabs <- unvec_vol(subcortLabs, subcortMask, fill=fill)
   if (!is.null(trans_mat)) {

README.Rmd

@@ -7,6 +7,7 @@ output: github_document
 # ciftiTools
 
 <!-- badges: start -->
+[![CRAN status](https://www.r-pkg.org/badges/version/ciftiTools)](https://cran.r-project.org/package=ciftiTools)
 [![R-CMD-check](https://github.com/mandymejia/ciftiTools/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/mandymejia/ciftiTools/actions/workflows/R-CMD-check.yaml)
 [![Codecov test coverage](https://codecov.io/gh/mandymejia/ciftiTools/branch/master/graph/badge.svg)](https://app.codecov.io/gh/mandymejia/ciftiTools?branch=master)
 <!-- badges: end -->

README.md

@@ -5,6 +5,8 @@
 
 <!-- badges: start -->
 
+[![CRAN
+status](https://www.r-pkg.org/badges/version/ciftiTools)](https://cran.r-project.org/package=ciftiTools)
 [![R-CMD-check](https://github.com/mandymejia/ciftiTools/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/mandymejia/ciftiTools/actions/workflows/R-CMD-check.yaml)
 [![Codecov test
 coverage](https://codecov.io/gh/mandymejia/ciftiTools/branch/master/graph/badge.svg)](https://app.codecov.io/gh/mandymejia/ciftiTools?branch=master)

cran-comments.md

@@ -6,9 +6,9 @@
 ## R CMD check results
 
 > checking installed package size ... NOTE
-    installed size is  7.6Mb
+    installed size is  6.7Mb
     sub-directories of 1Mb or more:
-      R         2.8Mb
+      R         1.8Mb
       extdata   4.3Mb
 
 0 errors v | 0 warnings v | 1 note x