Merge pull request #35 from mandymejia/8.0

8.1

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: ciftiTools
 Type: Package
 Title: Tools for Reading, Writing, Viewing and Manipulating CIFTI Files
-Version: 0.7.0
+Version: 0.8.1
 Authors@R: c(
     person(given = "Amanda",
            family = "Mejia",
@@ -49,6 +49,7 @@ Suggests:
     grid,
     gridExtra,
     htmlwidgets,
+    manipulateWidget,
     knitr,
     rmarkdown,
     papayar,

NAMESPACE

@@ -47,6 +47,7 @@ export(convert_xifti)
 export(expand_color_pal)
 export(fix_xifti)
 export(get_wb_cmd_path)
+export(infer_resolution)
 export(infoCIfTI)
 export(info_cifti)
 export(infocii)
@@ -83,6 +84,7 @@ export(resamplecii)
 export(resamplegii)
 export(rotate_surf)
 export(run_wb_cmd)
+export(scale_xifti)
 export(select_xifti)
 export(separateCIfTI)
 export(separate_cifti)

R/add_surf.R

@@ -29,7 +29,7 @@ add_surf <- function(xifti, surfL=NULL, surfR=NULL) {
       xifti$surf$cortex_left <- load_surf("left", surfL, resamp_res)
     } else {
       z <- read_surf(surfL, "left")
-      if (nrow(z$vertices) != resamp_res) { z <- resample_surf(z, resamp_res, "left") }
+      if (!is.null(resamp_res) && nrow(z$vertices) != resamp_res) { z <- resample_surf(z, resamp_res, "left") }
       xifti$surf$cortex_left <- z
     }
   }
@@ -43,7 +43,7 @@ add_surf <- function(xifti, surfL=NULL, surfR=NULL) {
       xifti$surf$cortex_right <- load_surf("right", surfR, resamp_res=resamp_res)
     } else {
       z <- read_surf(surfR, "right")
-      if (nrow(z$vertices) != resamp_res) { z <- resample_surf(z, resamp_res, "right") }
+      if (!is.null(resamp_res) && nrow(z$vertices) != resamp_res) { z <- resample_surf(z, resamp_res, "right") }
       xifti$surf$cortex_right <- z
     }
   }

R/ciftiTools-package.R

@@ -37,6 +37,8 @@
 #'  \item{\code{select_xifti}:}{   Select data matrix columns of a \code{"xifti"}}
 #'  \item{\code{transform_xifti}:}{   Apply a univariate transformation to a \code{"xifti"} or pair of \code{"xifti"}s}
 #'  \item{\code{add_surf}:}{   Add surfaces to a \code{"xifti"}}
+#'  \item{\code{move_from_mwall}:}{   Move medial wall vertices back into the \code{"xifti"} data matrix}
+#'  \item{\code{move_to_mwall}:}{   Move rows with a certain value into the \code{"xifti"} medial wall mask}
 #' }
 #' 
 #' S3 methods for \code{"xifti"}s:

R/expect_equal_xifti.R

@@ -2,8 +2,8 @@
 #' 
 #' Raise an error if the \code{"xifti"}s do not match. 
 #' 
-#' \code{cifti$intent} and \code{cifti$brainstructures} are only compared if they
-#'  exist for both files. \code{cifti$misc} is never compared. 
+#' \code{cifti$intent} is only compared if it
+#'  exists for both files. \code{cifti$brainstructures} and \code{cifti$misc} are not compared. 
 #' 
 #' @param xii1 The first \code{"xifti"}
 #' @param xii2 The second \code{"xifti"}
@@ -30,7 +30,8 @@ expect_equal_xifti <- function(xii1, xii2) {
     testthat::expect_equal(xii1$meta$cifti$intent, xii2$meta$cifti$intent)
   }
 
-  if (!is.null(xii1$meta$cifti$brainstructure) && !is.null(xii2$meta$cifti$brainstructure)) {
-    testthat::expect_equal(xii1$meta$cifti$brainstructure, xii2$meta$cifti$brainstructure)
-  }
+  # [TO DO]: Define this?
+  # if (!is.null(xii1$meta$cifti$brainstructure) && !is.null(xii2$meta$cifti$brainstructure)) {
+  #   testthat::expect_equal(xii1$meta$cifti$brainstructure, xii2$meta$cifti$brainstructure)
+  # }
 }

R/info_cifti.R

@@ -85,15 +85,15 @@ check_cifti_type <- function(intent, extn){
         "This CIFTI file has intent code", intent, "and extension", extn,
         "neither of which is supported by ciftiTools (yet).",
         "Only the following types are:\n\t",
-        paste(supported_intents()$value, collapse="\t "),
+        paste(supported_intents()$value, collapse="\n\t "),
         "\nRespectively, they correspond to these file extensions:\n\t",
-        paste(supported_intents()$extension, collapse="\t ")
+        paste(supported_intents()$extension, collapse="\n\t ")
       ))
     } else {
       warning(paste(
         "This CIFTI file has extension", extn, "which is not yet supported by ciftiTools.",
         "Only the following types are:\t",
-        paste(supported_intents()$extension, collapse="\t "),
+        paste(supported_intents()$extension, collapse="\n\t "),
         "\nThe intent code", intent, "is supported but does not match the extension.",
         "Was the file named incorrectly?",
         "Continuing anyway with the intent code", intent, "and correct extension",
@@ -264,14 +264,18 @@ get_data_meta_from_cifti_xml <- function(xml, intent=3000) {
     meta$subcort_trans_units <- as.numeric(
       attr(xml$Volume$TransformationMatrixVoxelIndicesIJKtoXYZ, "MeterExponent")
     )
-    if (meta$subcort_trans_units == -3) {
-      meta$subcort_trans_units <- "mm"
-    } else if (meta$subcort_trans_units == -2) {
-      meta$subcort_trans_units <- "cm"
-    } else if (meta$subcort_trans_units == 0) {
-      meta$subcort_trans_units <- "m"
+    if (length(meta$subcort_trans_units) > 0) {
+      if (meta$subcort_trans_units == -3) {
+        meta$subcort_trans_units <- "mm"
+      } else if (meta$subcort_trans_units == -2) {
+        meta$subcort_trans_units <- "cm"
+      } else if (meta$subcort_trans_units == 0) {
+        meta$subcort_trans_units <- "m"
+      } else {
+        meta$subcort_trans_units <- paste0("10^(", meta$subcort_trans_units, ") m")
+      }
     } else {
-      meta$subcort_trans_units <- paste0("10^(", meta$subcort_trans_units, ") m")
+      meta["subcort_trans_units"] <- list(NULL)
     }
 
     meta$subcort_dims <- as.numeric(

R/is.xifti.R

@@ -287,8 +287,11 @@ is.xifti_meta <- function(x) {
   }
 
   # Subcortical.
-  if (!match_exactly(names(x$subcort), names(y$subcort))) { 
-    message("Subcortical sublist names are not correct.\n"); return(FALSE) 
+  if (!match_exactly(names(x$subcort), names(y$subcort), fail_action="nothing")) { 
+    ny2 <- names(y$subcort)[names(y$subcort) != "trans_units"]
+    if (!match_exactly(names(x$subcort), ny2, fail_action="message")) { 
+      message("Subcortical sublist names are not correct.\n"); return(FALSE) 
+    }
   }
   if (!is.null(x$subcort$labels) && !is.subcort_labs(x$subcort$labels)) {
     message("Subcortical labels are invalid.\n"); return(FALSE)
@@ -315,12 +318,28 @@ is.xifti_meta <- function(x) {
 
   # cifti
   if (!is.null(x$cifti)) {
-    if (!all(x$cifti$brainstructures %in% c("left", "right", "subcortical"))) {
-      message(paste(
-        "CIFTI brainstructures must be one or several of the following:",
-        "left, righ, subcortical.\n"
-      ))
-      return(FALSE)
+    if (!is.null(x$cifti$brainstructures)) {
+      # All entries must be valid.
+      if (!all(x$cifti$brainstructures %in% c("left", "right", "subcortical"))) {
+        message(paste(
+          "CIFTI brainstructures must be one or several of the following:",
+          "left, right, subcortical.\n"
+        ))
+        return(FALSE)
+      }
+      # All brainstructures with data must be included.
+      bs_expected <- names(x$data)[!vapply(x$data, is.null, FALSE)]
+      bs_missing <- setdiff(bs_expected, x$cifti$brainstructures)
+      if (length(bs_missing) > 0) {
+        message(paste(
+          "These brainstructures with data are not in $meta$cifti$brainstructures:",
+          paste(bs_missing, collapse=", "), 
+          ". Add them or set this metadata entry to `NULL`.\n"
+        ))
+        return(FALSE)
+      }
+      # [TO DO]: check `bs_expected`
+      # I forget if `brainstructures` are those originally in the `xifti`, or just those present now?
     }
 
     if (!is.null(x$cifti$intent)) {

R/make_xifti.R

@@ -273,6 +273,12 @@ make_xifti <- function(
   # Column names.
   if (!is.null(col_names)) { xifti$meta$cifti$names <- col_names }
 
+  # Brainstructures.
+  # bs_names <- names(xifti$data)[!vapply(xifti$data, is.null, FALSE)]
+  # bs_names <- c(cortex_left="left", cortex_right="right", subcort="subcortical")[bs_names]
+  # xifti$meta$cifti$brainstructures <- bs_names
+  xifti$meta$cifti["brainstructures"] <- list(NULL)
+
   # idx metadata.
   if (!is.null(idx)) { xifti$meta$cifti$misc$idx <- idx }
 

R/newdata_xifti.R

@@ -2,15 +2,25 @@
 #' 
 #' Replace the data in a \code{"xifti"} with new data from a data matrix.
 #' 
-#' If the \code{"xifti"} has \eqn{V} grayordinates and \code{T} measurements
-#'  in total, \code{newdata} should be a \eqn{V \times T} matrix.
+#' If the \code{"xifti"} has \eqn{V} grayordinates and \eqn{T} measurements\, 
+#'  \code{newdata} should be a \eqn{V \times Q} matrix. If \eqn{Q}
+#'  is not equal to \eqn{T}, then any column names or label tables will be
+#'  removed. (A "dlabel" will be converted to a "dscalar".)
 #' @param xifti The \code{"xifti"}
-#' @param newdata The \eqn{V \ times T} matrix of data values to replace those
+#' @param newdata The \eqn{V \times T} matrix of data values to replace those
 #'  in \code{xifti} with. The left cortex vertices should be at the top, right
 #'  cortex vertices in the middle, and subcortex vertices at the bottom (when
-#'  present). Can also be a length-one vector to set all values equally.
-#' @param newnames Replace the names in the \code{xifti}. If \code{NULL}
-#'  (default), keep the original names.
+#'  present).
+#' 
+#'  If \code{newdata} is instead a \eqn{V \times Q} matrix where \eqn{Q} is not
+#'  \eqn{T}, then any column names or label tables will be removed. 
+#'  (A "dlabel" will be converted to a "dscalar".)
+#' 
+#'  Can also be a length-one vector to set all values equally.
+#' @param newnames Replaces the names in the \code{xifti}. If \code{NULL}
+#'  (default), keep the original names, except if the number of columns
+#'  in \code{newdata} doesn't match that of \code{xifti}, in which case
+#'  no names will be used.
 #' @return The new \code{"xifti"}
 #' 
 #' @family manipulating
@@ -25,17 +35,29 @@ newdata_xifti <- function(xifti, newdata, newnames=NULL) {
     if (length(newdata) == 1) {
       newdata <- matrix(newdata, nrow=xifti_dim[1], ncol=xifti_dim[2])
     } else {
-      newdata <- matrix(newdata, ncol=xifti_dim[2])
+      newdata <- matrix(newdata, nrow=xifti_dim[1])
     }
     newdata_dim <- dim(newdata)
   }
   stopifnot(length(newdata_dim)==2)
 
   xifti_dim <- dim(xifti)
+  same_columns <- TRUE
   if (!all(xifti_dim == newdata_dim)) {
+    # Transposed input.
     if (all(xifti_dim == rev(newdata_dim))) {
       warning("Transposing `newdata`.\n")
       newdata <- t(newdata)
+
+    # Different number of columns.
+    } else if (xifti_dim[1] == newdata_dim[1]) {
+      xifti <- select_xifti(xifti, rep(1, newdata_dim[2]))
+      same_columns <- FALSE
+      if (!is.null(xifti$meta$cifti$intent) && xifti$meta$cifti$intent == 3007) {
+        warning("Mismatch # columns: converting to `dscalar`.\n")
+        xifti <- convert_xifti(xifti, "dscalar")
+      }
+    # Error.
     } else {
       stop(
         "`xifti` and `newdata` do not have the same dimensions.\n",
@@ -54,25 +76,29 @@ newdata_xifti <- function(xifti, newdata, newnames=NULL) {
     }
   }
 
+  # New data.
+  V_start <- 0
+  for (bs in names(xifti$data)) {
+    if (!is.null(xifti$data[[bs]])) {
+      V_bs <- nrow(xifti$data[[bs]])
+      xifti$data[[bs]] <- newdata[seq(V_start+1, V_bs+V_start),,drop=FALSE]
+      V_start <- V_bs+V_start
+    }
+  }
+
   # New names.
   if (!is.null(newnames)) {
-    if (length(newnames) != xifti_dim[2]) {
-      stop("The length of `newnames` does not match the number of columns in the `xifti`.")
+    if (length(newnames) != newdata_dim[2]) {
+      stop("The length of `newnames` does not match the number of columns in the new `xifti`.")
     }
     if (!is.null(xifti$meta$cifti$intent) && xifti$meta$cifti$intent == 3002) {
       warning("The dtseries intent (3002) does not use column names. Ignoring `newnames`.")
     } else {
       xifti$meta$cifti$names <- newnames
     }
-  }
-
-  # New data.
-  V_start <- 0
-  for (bs in names(xifti$data)) {
-    if (!is.null(xifti$data[[bs]])) {
-      V_bs <- nrow(xifti$data[[bs]])
-      xifti$data[[bs]] <- newdata[seq(V_start+1, V_bs+V_start),,drop=FALSE]
-      V_start <- V_bs+V_start
+  } else if (!same_columns) {
+    if (!(is.null(xifti$meta$cifti$intent) || xifti$meta$cifti$intent == 3002)) {
+      xifti$meta$cifti$names <- paste("Column", seq(ncol(newdata)))
     }
   }
 

R/read_surf.R

@@ -118,5 +118,5 @@ read_surf <- function(surf, expected_hemisphere=NULL, resamp_res=NULL) {
 #' @rdname read_surf
 #' @export
 make_surf <- function(surf, expected_hemisphere=NULL, resamp_res=NULL){
-  read_surf(surf=surf, expected_hemisphere=expected_hemisphere, resamp_res=NULL)
+  read_surf(surf=surf, expected_hemisphere=expected_hemisphere, resamp_res=resamp_res)
 }