Nothing
#' Prep an [ijtiff_img]-style array for `write_tif_C()`.
#'
#' It has to be a list of 3-dimensional arrays. Heavy lifting done in C++ by
#' `enlist_img_cpp()`.
#'
#' @param img An [ijtiff_img]-style array.
#'
#' @return A list.
#'
#' @noRd
enlist_img <- function(img) {
checkmate::assert_array(img, d = 4, mode = "double")
.Call("enlist_img_C", img, PACKAGE = "ijtiff")
}
#' Split the planes of a 3D array into a list.
#'
#' Planes are along the 3rd dimension.
#'
#' @param arr3d A 3D array.
#'
#' @return A list of 2D arrays.
#'
#' @noRd
enlist_planes <- function(arr3d) {
checkmate::assert_array(arr3d, d = 3, mode = "double")
.Call("enlist_planes_C", arr3d, PACKAGE = "ijtiff")
}
#' Calculate [dim()] on every element in a list.
#'
#' @param lst A list.
#'
#' @return A list.
#'
#' @noRd
dims <- function(lst) {
checkmate::assert_list(lst)
.Call("dims_C", lst, PACKAGE = "ijtiff")
}
#' Extract the appropriate plane.
#'
#' Sometimes the TIFF reading is weird and you get more planes than you wanted,
#' but one of them is clearly the right one. This function will pluck that out
#' for you.
#'
#' @param arr An array. Mostly 3D. If 2D, input is returned.
#'
#' @return A 2D array.
#'
#' @noRd
extract_desired_plane <- function(arr) {
checkmate::assert_array(arr, min.d = 2, max.d = 3)
d <- dim(arr)
if (length(d) == 3) {
nonzero_planes <- !purrr::map_lgl(
seq_len(d[3]),
~ isTRUE(unique(as.vector(arr[, , .])) == 0)
)
if (sum(nonzero_planes) == 1) {
arr <- arr[, , nonzero_planes]
} else if (dplyr::n_distinct(enlist_planes(arr)) == 1) {
arr <- arr[, , 1]
} else {
n_nonzero_unique_planes <- arr %>%
enlist_planes() %>%
unique() %>%
length()
rlang::abort(
c("Cannot extract the desired plane.",
x = stringr::str_glue(
"There are {n_nonzero_unique_planes} unique nonzero ",
"planes, so it is impossible to decipher which is the ",
"correct one to extract."
)
)
)
}
}
arr
}
#' Compute the desired plane.
#'
#' This function wraps [extract_desired_plane()]. Sometimes the TIFF reading is
#' weird and you get more planes than you wanted, but one of them is clearly the
#' right one. This function will pluck that out for you. If the images have a
#' color palette, that conversion takes place here too.
#'
#' @inheritParams extract_desired_plane
#'
#' @return A 2D array.
#'
#' @noRd
compute_desired_plane <- function(arr) {
atts <- attributes(arr)
att_names <- names(atts)
if (all(c("color_space", "color_map") %in% att_names) &&
isTRUE(atts$color_space == "palette")) {
return(match_pillar_to_row_3(arr, attr(arr, "color_map", exact = TRUE)))
}
extract_desired_plane(arr)
}
#' Find the lowest number that is bigger than all the elements in `x`.
#'
#' @param x A numeric vector.
#' @param possible_upper_bounds A numeric vector.
#' @param na_rm Ignore `NA`s?
#'
#' @return A number.
#'
#' @noRd
lowest_upper_bound <- function(x, possible_upper_bounds, na_rm = TRUE) {
checkmate::assert_numeric(x, min.len = 1)
checkmate::assert_numeric(possible_upper_bounds, min.len = 1)
checkmate::assert_flag(na_rm)
if (anyNA(x) && rlang::is_false(na_rm)) {
return(NA_real_)
}
mx <- suppressWarnings(max(as.vector(x), na.rm = na_rm))
if (is.na(mx) || is.infinite(mx)) {
return(NA_real_)
}
possible_upper_bounds <- sort(possible_upper_bounds)
for (pub in possible_upper_bounds) {
if (pub >= mx) {
return(pub)
}
}
return(NA_real_)
}
#' Fix the resolution unit if necessary.
#'
#' The resolution unit is another thing that ImageJ sometimes decides to record
#' in `TIFFTAG_DESCRIPTION` so needs to be allowed for.
#'
#' @param x An [ijtiff_img] which optionally has a `description` attribute with
#' the contents of `TIFFTAG_DESCRIPTION`.
#'
#' @return An [ijtiff_img].
#'
#' @noRd
fix_res_unit <- function(x) {
if ("description" %in% names(attributes(x)) &&
startsWith(attr(x, "description"), "ImageJ") &&
(is.null(attr(x, "resolution_unit")) ||
attr(x, "resolution_unit") == "none") &&
stringr::str_detect(attr(x, "description"), "\\sunit=.+\\s")) {
attr(x, "resolution_unit") <- stringr::str_match(
attr(x, "description"), "\\sunit=([^\\s]+)"
)[1, 2]
}
x
}
#' Does the object read by `read_tif_C()` have a colormap or channels specified
#' in the weird ImageJ way?
#'
#' @param img_lst A list. The output of `read_tif_C()`.
#' @param prep The output of a call to `prep_read()`.
#' @param d The dimension of the images in `img_lst`.
#'
#' @return A flag.
#'
#' @noRd
colormap_or_ij_channels <- function(img_lst, prep, d) {
weird_ij_channels <- (isTRUE(length(img_lst) == prep$n_imgs) && prep$ij_n_ch)
colormap <- (!prep$ij_n_ch && prep$n_ch == 1) && (length(d) > 2)
colormap || weird_ij_channels
}
#' Count the number of frames in a TIFF file.
#'
#' TIFF files can hold many frames. Often this is sensible, e.g. each frame
#' could be a time-point in a video or a slice of a z-stack.
#'
#' For those familiar with TIFF files, this function counts the number of
#' directories in a TIFF file. There is an adjustment made for some
#' ImageJ-written TIFF files.
#'
#' @inheritParams read_tif
#'
#' @return A number, the number of frames in the TIFF file. This has an
#' attribute `n_dirs` which holds the true number of directories in the TIFF
#' file, making no allowance for the way ImageJ may write TIFF files.
#'
#' @examples
#' count_frames(system.file("img", "Rlogo.tif", package = "ijtiff"))
#' @export
count_frames <- function(path) {
path <- prep_path(path)
withr::local_dir(attr(path, "path_dir"))
prep <- prep_read(path,
frames = "all",
tags1 = read_tags(path, frames = 1)[[1]]
)
out <- ifelse(is.na(prep$n_slices), prep$n_dirs, prep$n_slices)
attr(out, "n_dirs") <- prep$n_dirs
out
}
#' @rdname count_frames
#' @export
frames_count <- function(path) {
count_frames(path = path)
}
#' Is a numeric vector equal to its floor.
#'
#' This is different to [checkmate::check_integerish()] as it permits things
#' outside the 32-bit integer range.
#'
#' @param x A numeric vector.
#'
#' @return A flag.
#'
#' @noRd
can_be_intish <- function(x) isTRUE(all(x == floor(x)))
#' Check if an object is an [EBImage::Image].
#'
#' @param x An object.
#'
#' @return A flag.
#'
#' @noRd
is_EBImage <- function(x) {
suppressWarnings(
isTRUE("Image" %in% class(x)) &&
isTRUE(attr(class(x), "package") == "EBImage")
)
}
#' A message to tell the user to install EBImage.
#'
#' @return A string.
#'
#' @noRd
ebimg_install_msg <- function() {
paste0(
" * To install `EBImage`:", "\n",
" - Install `BiocManager` with `install.packages(\"BiocManager\")`.\n",
" - Then run `BiocManager::install(\"EBImage\")`."
)
}
#' Rejig linescan images.
#'
#' `ijtiff` has the fourth dimension of an [ijtiff_img] as its time dimension.
#' However, some linescan images (images where a single line of pixels is
#' acquired over and over) have the time dimension as the y dimension, (to avoid
#' the need for an image stack). These functions allow one to convert this type
#' of image into a conventional [ijtiff_img] (with time in the fourth dimension)
#' and to convert back.
#'
#' @param linescan_img A 4-dimensional array in which the time axis is the first
#' axis. Dimension 4 must be 1 i.e. `dim(linescan_img)[4] == 1`.
#' @param img A conventional [ijtiff_img], to be turned into a linescan image.
#' Dimension 1 must be 1 i.e. `dim(img)[1] == 1`.
#'
#' @return The converted image, an object of class [ijtiff_img].
#'
#' @examples
#' linescan <- ijtiff_img(array(rep(1:4, each = 4), dim = c(4, 4, 1, 1)))
#' print(linescan)
#' stack <- linescan_to_stack(linescan)
#' print(stack)
#' linescan <- stack_to_linescan(stack)
#' print(linescan)
#' @name linescan-conversion
NULL
#' @rdname linescan-conversion
#' @export
linescan_to_stack <- function(linescan_img) {
linescan_img <- ijtiff_img(linescan_img)
if (dim(linescan_img)[4] != 1) {
rlang::abort(
c(
paste(
"The fourth dimension of `linescan_img` should be equal to 1",
"(or else it's not a linescan image)."
),
stringr::str_glue(
"Yours has ",
"`dim(linescan_img)[4] == {dim(linescan_img)[4]}`."
)
)
)
}
linescan_img %>%
aperm(c(4, 2, 3, 1)) %>%
ijtiff_img()
}
#' @rdname linescan-conversion
#' @export
stack_to_linescan <- function(img) {
img <- ijtiff_img(img)
if (dim(img)[1] != 1) {
rlang::abort(
c(
paste(
"The first dimension of `img` should be equal to 1 (or",
"else it's not a stack that can be converted to a linescan)."
),
x = stringr::str_glue("Yours has dim(img)[1] == {dim(img)[1]}.")
)
)
}
img %>%
aperm(c(4, 2, 3, 1)) %>%
ijtiff_img()
}
#' Wrap messages to make them prettier.
#'
#' Format messages with line breaks so that single words don't appear on
#' multiple lines.
#'
#' @param ... Bits of the message to be pasted together.
#'
#' @noRd
pretty_msg <- function(...) {
dots <- unlist(list(...))
checkmate::assert_character(dots)
stringr::str_c(dots, collapse = "") %>%
strwrap(width = 63) %>%
stringr::str_c(collapse = "\n") %>%
message()
}
#' TIFF tag reference.
#'
#' A dataset containing the information on all known baseline and extended TIFF
#' tags.
#'
#' A data frame with 96 rows and 10 variables: \describe{
#' \item{code_dec}{decimal numeric code of the TIFF tag}
#' \item{code_hex}{hexadecimal numeric code of the TIFF tag} \item{name}{the
#' name of the TIFF tag} \item{short_description}{a short description of the
#' TIFF tag} \item{tag_type}{the type of TIFF tag: either "baseline" or
#' "extended"} \item{url}{the URL of the TIFF tag at
#' \url{https://www.awaresystems.be}} \item{libtiff_name}{the TIFF tag name in
#' the libtiff C library} \item{c_type}{the C type of the TIFF tag data in
#' libtiff} \item{count}{the number of elements in the TIFF tag data}
#' \item{default}{the default value of the data held in the TIFF tag} }
#' @source \url{https://www.awaresystems.be}
#'
#' @examples
#' tif_tags_reference()
#' @export
tif_tags_reference <- function() {
"TIFF_tags.csv" %>%
system.file("extdata", ., package = "ijtiff") %>%
readr::read_csv(., col_types = readr::cols())
}
#' Check that the `frames` argument has been passed correctly.
#'
#' @param frames An integerish vector. The requested frames.
#'
#' @return `TRUE` invisibly if everything is OK. The function errors otherwise.
#'
#' @noRd
prep_frames <- function(frames) {
checkmate::assert(
checkmate::check_string(frames),
checkmate::check_integerish(frames, lower = 1)
)
if (is.character(frames)) {
frames <- tolower(frames)
if (!startsWith("all", frames)) {
rlang::abort(
c("If `frames` is a string, it must be 'all'.",
x = stringr::str_glue("You have `frames = '{frames}'`.")
)
)
}
frames <- "all"
}
frames
}
#' Calculate the number of slices from an ImageJ `TIFFTAG_DESCRIPTION`.
#'
#' @param ij_description A string.
#'
#' @return A number.
#'
#' @noRd
calculate_n_slices <- function(ij_description) {
n_slices <- strex::str_first_number_after_first(ij_description, "slices=")
if (stringr::str_detect(ij_description, "frames=")) {
n_frames <- strex::str_first_number_after_first(
ij_description,
"frames="
)
if (!is.na(n_slices) && rlang::is_false(n_frames == n_slices)) {
if (isTRUE(n_slices == 1) || isTRUE(n_frames == 1)) {
n_slices <- n_frames <- max(n_slices, n_frames)
} else {
rlang::abort(
c(
stringr::str_glue(
"The ImageJ-written image you're trying to read says it ",
"has {n_frames} frames AND {n_slices} slices."
),
x = paste(
"To be read by the `ijtiff` package, the number of slices OR the",
"number of frames should be specified in the TIFFTAG_DESCRIPTION",
"and they're interpreted as the same thing. It does not make",
"sense for them to be different numbers."
)
)
)
}
}
n_slices <- n_frames
}
n_slices
}
#' Extract info from an ImageJ-style `TIFFTAG_DESCRIPTION`.
#'
#' @inheritParams prep_read
#'
#' @return A named list with elements `n_imgs`, `n_slices`, `ij_n_ch`, `n_ch`.
#'
#' @noRd
translate_ij_description <- function(tags1) {
n_imgs <- NA_integer_
n_slices <- NA_integer_
ij_n_ch <- FALSE
n_ch <- tags1$samples_per_pixel %||% 1
if ("description" %in% names(tags1) &&
startsWith(tags1$description, "ImageJ")) {
ij_description <- tags1$description
if (stringr::str_detect(ij_description, "channels=")) {
n_ch <- strex::str_first_number_after_first(
ij_description,
"channels="
)
ij_n_ch <- TRUE
}
n_imgs <- strex::str_first_number_after_first(ij_description, "images=")
n_slices <- calculate_n_slices(ij_description)
if ((!is.na(n_slices) && !is.na(n_imgs)) &&
ij_n_ch &&
n_imgs != n_ch * n_slices) {
rlang::abort(
c(
stringr::str_glue(
"The ImageJ-written image you're trying to read says in its ",
"TIFFTAG_DESCRIPTION that it has {n_imgs} images of ",
"{n_slices} slices of {n_ch} channels. However, with {n_slices} ",
"slices of {n_ch} channels, one would expect there to be ",
"{n_slices} x {n_ch} = {n_ch * n_slices} images."
),
x = paste(
"This discrepancy means that the `ijtiff` package",
"can't read your image correctly."
),
i = paste(
"One possible source of this kind of error is that your",
"image may be temporal and volumetric. `ijtiff` can handle",
"either time-based or volumetric stacks, but not both."
)
)
)
}
}
list(n_imgs = n_imgs, n_slices = n_slices, ij_n_ch = ij_n_ch, n_ch = n_ch)
}
#' Get information necessary for reading the image.
#'
#' While doing so, perform a check to see if the requested frames exist.
#'
#' @param path The path to the TIFF file.
#' @param frames An integerish vector. The requested frames.
#' @param tags1 The tags from the first image (directory) in the TIFF file. The
#' first element of an output from [read_tags()].
#' @param tags Are we prepping the read of just tags (`TRUE`) or an image
#' (`FALSE`).
#'
#' @return A list with seven elements.
#' * `frames` is the adjusted frame numbers (allowing for _ImageJ_ stuff),
#' unique and sorted.
#' * `back_map` is a mapping from `frames` back to its non-unique, unsorted
#' original; that would be `frames[back_map]`.
#' * `n_ch` is the number of channels.
#' * `n_dirs` is the number of directories in the TIFF image.
#' * `n_slices` is the number of slices in the TIFF file. For most, this is the
#' same as `n_dirs` but for ImageJ-written images it can be different.
#' * `n_imgs` is the number of images according to the ImageJ
#' `TIFFTAG_DESCRIPTION`. If not specified, it's `NA`.
#' * `ij_n_ch` is `TRUE` if the number of channels was specified in the ImageJ
#' `TIFFTAG_DESCRIPTION`, otherwise `FALSE`.
#'
#' @noRd
prep_read <- function(path, frames, tags1, tags = FALSE) {
frames <- prep_frames(frames)
frames_max <- max(frames)
c(n_imgs, n_slices, ij_n_ch, n_ch) %<-% translate_ij_description(
tags1
)[c("n_imgs", "n_slices", "ij_n_ch", "n_ch")]
path <- prep_path(path)
withr::local_dir(attr(path, "path_dir"))
n_dirs <- .Call("count_directories_C", path, PACKAGE = "ijtiff")
if (!is.na(n_slices)) {
if (frames[[1]] == "all") {
frames <- seq_len(n_slices)
frames_max <- n_slices
}
if (frames_max > n_slices) {
rlang::abort(
stringr::str_glue(
"You have requested frame number {frames_max} but ",
"there are only {n_slices} frames in total."
)
)
}
if (ij_n_ch) {
if (n_dirs != n_slices) {
if (!is.na(n_imgs) && n_dirs != n_imgs) {
rlang::abort(
c(
paste(
"If TIFFTAG_DESCRIPTION specifies the number of images, this",
"must be equal to the number of directories in the TIFF file."
),
x = stringr::str_glue("Your TIFF file has {n_dirs} directories."),
x = stringr::str_glue(
"Its TIFFTAG_DESCRIPTION indicates that it",
" holds {n_imgs} images."
)
)
)
}
if (tags) {
frames <- frames * n_ch - (n_ch - 1)
} else {
frames <- purrr::map(
frames * n_ch,
~ .x - rev((seq_len(n_ch) - 1))
) %>%
unlist()
}
}
}
} else {
if (frames[[1]] == "all") {
frames <- seq_len(n_dirs)
frames_max <- n_dirs
}
if (frames_max > n_dirs) {
rlang::abort(
stringr::str_glue(
"You have requested frame number {frames_max} but",
" there are only {n_dirs} frames in total."
)
)
}
}
good_frames <- sort(unique(frames))
back_map <- match(frames, good_frames)
list(
frames = as.integer(good_frames),
back_map = back_map,
n_ch = n_ch,
n_dirs = n_dirs,
n_slices = ifelse(is.na(n_slices), n_dirs, n_slices),
n_imgs = n_imgs,
ij_n_ch = ij_n_ch
)
}
#' Prepare the path to a TIFF file for a function that will read from that file.
#'
#' The [fs::path_file()] is returned. The calling function is expected to call
#' `withr::local_dir(fs::path_dir())`.
#'
#' @param path A string. The path to a TIFF file.
#'
#' @return A string. The [fs::path_file()]. This has an attribute `path_dir`
#' with the path to be passed to [withr::local_dir()].
#'
#' @noRd
prep_path <- function(path) {
checkmate::assert_string(path)
path <- stringr::str_replace_all(path, stringr::coll("\\"), "/") # windows
checkmate::assert_file_exists(path)
structure(fs::path_file(path), path_dir = fs::path_dir(path))
}
#' Check if EBImage is installed.
#'
#' Error if not.
#'
#' @return `TRUE` (invisibly) if installed.
#'
#' @noRd
ebimg_check <- function() {
if (!rlang::is_installed("EBImage")) {
stop(paste0(
"To use this function, you need to have the `EBImage` package ",
"installed.", "\n", ebimg_install_msg()
))
}
invisible(TRUE)
}
match_pillar_to_row_3 <- function(arr3d, mat) {
checkmate::assert_array(arr3d, d = 3, mode = "double")
checkmate::assert_matrix(mat, mode = "integer")
.Call("match_pillar_to_row_3_C", arr3d, mat, PACKAGE = "ijtiff")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.