Fix lints

.lintr

@@ -10,5 +10,9 @@ linters: linters_with_tags(
     object_usage_linter = NULL,
     commented_code_linter = NULL,
     indentation_linter = NULL,
-    cyclocomp_linter = NULL
+    cyclocomp_linter = NULL,
+    implicit_assignment_linter(
+      except = c("bquote", "expression", "expr", "quo", "quos", "quote",
+        "expect_message", "expect_warning")
+    )
   )

NAMESPACE

@@ -141,6 +141,7 @@ importFrom(stats,setNames)
 importFrom(stats,var)
 importFrom(tools,file_path_sans_ext)
 importFrom(utils,combn)
+importFrom(utils,hasName)
 importFrom(utils,head)
 importFrom(utils,object.size)
 importFrom(utils,tail)

R/acuityview_pad.R

@@ -1,14 +1,15 @@
 #' @importFrom stats fft
 acuityview_pad <- function(image, obj_dist, obj_width, eye_res) {
-
   # Vector of powers of 2 up until realistic maximum possible image dimension. Clumsy.
   pow2 <- 2^(1:100)
 
   # Square & power-2 check
   square <- dim(image)[1] == dim(image)[2] && is.element(dim(image)[1], pow2)
 
   # Zero-pad if not square with dimension power-2
-  if (!square) {
+  if (square) {
+    image_pad <- image
+  } else {
     # Minimum necessary square dimension
     necessary_dim <- max(pow2[min(which(pow2 >= nrow(image)))], pow2[min(which(pow2 >= ncol(image)))])
 
@@ -21,8 +22,6 @@ acuityview_pad <- function(image, obj_dist, obj_width, eye_res) {
     for (i in 1:3) {
       image_pad[, , i] <- img_pad(image[, , i], col_pad, row_pad, opt = "pad", pad_fun = median(image))
     }
-  } else {
-    image_pad <- image
   }
 
   # Image width in degrees
@@ -36,24 +35,24 @@ acuityview_pad <- function(image, obj_dist, obj_width, eye_res) {
 
   # Create an MTF matrix with dimensions equal to the image
   MTF <- matrix(NA, nrow = dim(image_pad)[2], ncol = dim(image_pad)[1])
-    for (i in 1:width_pix){
-      for (j in 1:width_pix) {
-        x <- i - center
-        y <- j - center
-        freq <- round(sqrt(x^2 + y^2)) / width_pix * (width_pix / width_deg)
-        mySin <- y / sqrt(x^2 + y^2)
-        myCos <- x / sqrt(x^2 + y^2)
-        eye_res2 <- eye_res * eye_res / sqrt((eye_res * myCos)^2 + (eye_res * mySin)^2)
-        MTF[i, j] <- exp(-3.56 * (eye_res2 * freq)^2)
-      }
+  for (i in 1:width_pix) {
+    for (j in 1:width_pix) {
+      x <- i - center
+      y <- j - center
+      freq <- round(sqrt(x^2 + y^2)) / width_pix * (width_pix / width_deg)
+      mySin <- y / sqrt(x^2 + y^2)
+      myCos <- x / sqrt(x^2 + y^2)
+      eye_res2 <- eye_res * eye_res / sqrt((eye_res * myCos)^2 + (eye_res * mySin)^2)
+      MTF[i, j] <- exp(-3.56 * (eye_res2 * freq)^2)
+    }
   }
 
   # Force the center to 1
-  MTF[center, center] <-  1
+  MTF[center, center] <- 1
 
   # Cancel effect of MTF for non-real (padded) image regions
   # Don't think it's necessary, but keeping for now
-  #MTF <- img_pad(MTF, col_pad, row_pad, opt = 'MTF')
+  # MTF <- img_pad(MTF, col_pad, row_pad, opt = 'MTF')
 
   # Linearise sRGB values
   from_srgb <- function(rgb_dat) {
@@ -85,12 +84,12 @@ acuityview_pad <- function(image, obj_dist, obj_width, eye_res) {
   }
 
   # Crop image back to original dimensions
-  if (!square) {
+  if (square) {
+    image <- image_pad
+  } else {
     for (i in 1:3) {
       image[, , i] <- img_pad(image_pad[, , i], col_pad, row_pad, opt = "crop")
     }
-  } else {
-    image <- image_pad
   }
 
   # Re-scale to a max of 1 if any values end up > 1
@@ -111,7 +110,6 @@ acuityview_pad <- function(image, obj_dist, obj_width, eye_res) {
 # Rearrange the output of the FFT by moving
 # the zero frequency component to the center
 fft_shift <- function(input_matrix) {
-
   rows <- dim(input_matrix)[1]
   cols <- dim(input_matrix)[2]
 
@@ -136,14 +134,14 @@ fft_shift <- function(input_matrix) {
 img_pad <- function(dat, col_zeros, row_zeros, opt = c("pad", "crop", "MTF"), pad_fun) {
   if (opt == "pad") {
     # Add column padding
-      mat_col_low <- matrix(pad_fun, nrow(dat), floor(col_zeros))
-      mat_col_high <- matrix(pad_fun, nrow(dat), ceiling(col_zeros))
-      out <- cbind(mat_col_low, dat, mat_col_high)
+    mat_col_low <- matrix(pad_fun, nrow(dat), floor(col_zeros))
+    mat_col_high <- matrix(pad_fun, nrow(dat), ceiling(col_zeros))
+    out <- cbind(mat_col_low, dat, mat_col_high)
 
     # Add row padding
-      mat_colrow_low <- matrix(pad_fun, floor(row_zeros), ncol(out))
-      mat_colrow_high <- matrix(pad_fun, ceiling(row_zeros), ncol(out))
-      out2 <- rbind(mat_colrow_low, out, mat_colrow_high)
+    mat_colrow_low <- matrix(pad_fun, floor(row_zeros), ncol(out))
+    mat_colrow_high <- matrix(pad_fun, ceiling(row_zeros), ncol(out))
+    out2 <- rbind(mat_colrow_low, out, mat_colrow_high)
   }
 
   if (opt == "crop") {

R/adjacent.R

@@ -98,7 +98,7 @@
 #'
 #' @seealso [classify()], [summary.rimg()], [procimg()]
 #'
-#' @importFrom utils head object.size tail
+#' @importFrom utils head object.size tail hasName
 #' @importFrom future.apply future_lapply
 #' @importFrom progressr with_progress progressor
 #'
@@ -190,7 +190,7 @@ adjacent <- function(classimg, xpts = NULL, xscale = NULL, bkgID = NULL,
 
   ## Colour-classified
   if (any(unlist(lapply(classimg, attr, "state")) != "colclass")) {
-    stop("One or more images has not yet been colour-classified. See classify().")
+    stop("One or more images has not yet been colour-classified. See classify().", call. = FALSE)
   }
 
   ## Coldists formatting
@@ -207,7 +207,7 @@ adjacent <- function(classimg, xpts = NULL, xscale = NULL, bkgID = NULL,
       coldists <- lapply(coldists, function(x) names(x)[1:2] <- c("c1", "c2"))
     }
     if (any(unlist(lapply(coldists, function(x) !any(c("dS", "dL") %in% names(x)))))) {
-      stop("One or more set of coldists without columns labelled either 'dS' or 'dL'.")
+      stop("One or more set of coldists without columns labelled either 'dS' or 'dL'.", call. = FALSE)
     }
   }
 
@@ -217,22 +217,22 @@ adjacent <- function(classimg, xpts = NULL, xscale = NULL, bkgID = NULL,
       message("Using single set of hsl values for all images.")
       hsl <- rep(list(hsl), length(classimg))
     }
-    if (!all(unlist(lapply(hsl, function(x) "patch" %in% names(x))))) {
+    if (!all(vapply(hsl, hasName, "patch", FUN.VALUE = logical(1)))) {
       message(
         "Cannot find column named 'patch' one or more set of hsl values. ",
         "Assuming first column contains colour-category ID's"
       )
       hsl <- lapply(hsl, function(x) names(x)[1] <- "patch")
     }
     if (any(unlist(lapply(hsl, function(x) !any(c("hue", "sat", "lum") %in% names(x)))))) {
-      stop("One or more sets of hsl values without columns labelled either 'hue', 'sat', or 'lum'.")
+      stop("One or more sets of hsl values without columns labelled either 'hue', 'sat', or 'lum'.", call. = FALSE)
     }
   }
 
   ## Outline formatting
   if (!is.null(polygon)) {
     if (length(polygon) != length(classimg)) {
-      stop("One polygon per image is required.")
+      stop("One polygon per image is required.", call. = FALSE)
     }
     if (!all(c("x", "y") %in% names(unlist(polygon)))) {
       message("Cannot find columns named x and y in outline, taking the first two columns as x-y coordinates")
@@ -247,18 +247,15 @@ adjacent <- function(classimg, xpts = NULL, xscale = NULL, bkgID = NULL,
   }
 
   ## Exclusion checks
-  if ("background" %in% exclude2) {
-    if (is.null(bkgID) && is.null(attr(classimg, "outline"))) {
-      stop(
-        "Background cannot be excluded without specifying a focal object outline (e.g. using procimg()), ",
-        "or one or more colour-class ID's via the argument bkgID."
-      )
-    }
+  if ("background" %in% exclude2 && is.null(bkgID) && is.null(attr(classimg, "outline"))) {
+    stop(
+      "Background cannot be excluded without specifying a focal object outline (e.g. using procimg()), ",
+      "or one or more colour-class ID's via the argument bkgID.",
+      call. = FALSE
+    )
   }
-  if ("object" %in% exclude2) {
-    if (is.null(attr(classimg, "outline"))) {
-      stop("Focal object cannot be excluded without specifying its outline, (e.g. via procimg()).")
-    }
+  if ("object" %in% exclude2 && is.null(attr(classimg, "outline"))) {
+    stop("Focal object cannot be excluded without specifying its outline, (e.g. via procimg()).", call. = FALSE)
   }
 
   ## Setting scales
@@ -274,7 +271,8 @@ adjacent <- function(classimg, xpts = NULL, xscale = NULL, bkgID = NULL,
   } else {
     stop(
       "Required argument xscale is missing or incorrectly specified, and one or more images are uncalibrated. ",
-      "Either specify xscale (an integer or integers) or use procimg() to set a scale for each image."
+      "Either specify xscale (an integer or integers) or use procimg() to set a scale for each image.",
+      call. = FALSE
     )
   }
 
@@ -338,7 +336,6 @@ adjacent <- function(classimg, xpts = NULL, xscale = NULL, bkgID = NULL,
 #' @importFrom utils head tail
 adjacent_main <- function(classimg_i, xpts_i = NULL, xscale_i = NULL, bkgID_i = NULL,
                           exclude2_i = NULL, coldists_i = NULL, hsl_i = NULL) {
-
   ## ------------------------------ Summarising ------------------------------ ##
 
   c1 <- c2 <- NULL
@@ -367,16 +364,13 @@ adjacent_main <- function(classimg_i, xpts_i = NULL, xscale_i = NULL, bkgID_i =
       classimg_i[classimg_i %in% bkgID_i] <- 999
     }
   }
-  if ("object" %in% exclude2_i) {
-    # Complex backgrounds only
-    if (bkgoutline) {
-      # NA everything *inside* the outlined polyogn
-      classimg_i <- polymask(classimg_i,
-        attr(classimg_i, "outline"),
-        "inside",
-        replacement_value = 999
-      )
-    }
+  if ("object" %in% exclude2_i && bkgoutline) { # Complex backgrounds only
+    # NA everything *inside* the outlined polyogn
+    classimg_i <- polymask(classimg_i,
+      attr(classimg_i, "outline"),
+      "inside",
+      replacement_value = 999
+    )
   }
 
   # Grid subsample
@@ -403,11 +397,11 @@ adjacent_main <- function(classimg_i, xpts_i = NULL, xscale_i = NULL, bkgID_i =
   transitions <- transitioncalc(subclass, colournames)
 
   # Raw diag/offdiag
-  diag <- subset(transitions[["all"]], c1 == c2)
+  ondiag <- subset(transitions[["all"]], c1 == c2)
   offdiag <- subset(transitions[["all"]], c1 != c2)
 
   # Proportion diag/offdiag
-  diagprop <- diag
+  diagprop <- ondiag
   diagprop$N <- diagprop$N / sum(diagprop$N)
   offdiagprop <- offdiag
   offdiagprop$N <- offdiagprop$N / sum(offdiagprop$N)
@@ -445,7 +439,6 @@ adjacent_main <- function(classimg_i, xpts_i = NULL, xscale_i = NULL, bkgID_i =
       m_lum <- s_lum <- cv_lum <- NA
     }
   } else {
-
     # n colour classes
     k <- n_class
 
@@ -501,7 +494,6 @@ adjacent_main <- function(classimg_i, xpts_i = NULL, xscale_i = NULL, bkgID_i =
 
     ## Things involving the background
     if ("none" %in% exclude2_i && any(bkgoutline, !is.null(bkgID_i))) {
-
       # Animal only
       if (bkgoutline) {
         anim <- polymask(classimg_i, attr(classimg_i, "outline"), "outside")
@@ -559,7 +551,8 @@ adjacent_main <- function(classimg_i, xpts_i = NULL, xscale_i = NULL, bkgID_i =
           c(as.character(coldists_i$c1), as.character(coldists_i$c2)))) {
           stop(
             "Color-classes IDs listed in coldists do not match those of the image data. ",
-            "Edit the IDs in coldists, or rename the color categories in the classified image data."
+            "Edit the IDs in coldists, or rename the color categories in the classified image data.",
+            call. = FALSE
           )
         }
 
@@ -654,11 +647,11 @@ polymask <- function(imagedat,
     sf::st_sfc,
     apply(imglong[, c("x", "y")], 1, sf::st_point, simplify = FALSE)
   )
-  poly <- sf::st_polygon(list(as.matrix(polygon)))
+  sf_poly <- sf::st_polygon(list(as.matrix(polygon)))
 
   # It's safe to extract just the first column since at the moment, we can only
   # have a single polygon
-  inpoly <- sf::st_intersects(pts, poly, sparse = FALSE)[, 1]
+  inpoly <- sf::st_intersects(pts, sf_poly, sparse = FALSE)[, 1]
 
   maskmat <- matrix(data = inpoly, ncol(imagedat), nrow(imagedat))
   maskmat <- apply(as.matrix(maskmat), 1, rev)
@@ -690,9 +683,9 @@ transitioncalc <- function(classimgdat, colornames) {
   rt <- rt[!grepl("NA", rt[, 1], fixed = TRUE), ] # Remove columns containing NA's (i.e. bkg, if chosen to exclude)
   rnames <- as.numeric(unlist(strsplit(rt[, 1], ".", fixed = TRUE))) # split up transition names
   rowtrans <- data.frame(
-    "c1" = rnames[seq(1, length(rnames), 2)],
-    "c2" = rnames[seq(2, length(rnames), 2)],
-    "N" = rt[, 2]
+    c1 = rnames[seq(1, length(rnames), 2)],
+    c2 = rnames[seq(2, length(rnames), 2)],
+    N = rt[, 2]
   )
 
   # All column transitions
@@ -710,9 +703,9 @@ transitioncalc <- function(classimgdat, colornames) {
   ct <- ct[!grepl("NA", ct[, 1], fixed = TRUE), ] # Remove columns containing NA's (i.e. bkg, if chosen to exclude)
   cnames <- as.numeric(unlist(strsplit(ct[, 1], ".", fixed = TRUE))) # split up transition names
   coltrans <- data.frame(
-    "c1" = cnames[seq(1, length(cnames), 2)],
-    "c2" = cnames[seq(2, length(cnames), 2)],
-    "N" = ct[, 2]
+    c1 = cnames[seq(1, length(cnames), 2)],
+    c2 = cnames[seq(2, length(cnames), 2)],
+    N = ct[, 2]
   )
 
   # Sort

R/aggplot.R

@@ -53,7 +53,6 @@
 
 aggplot <- function(rspecdata, by = NULL, FUN.center = mean, FUN.error = sd,
                     lcol = NULL, shadecol = NULL, alpha = 0.2, legend = FALSE, ...) {
-
   # take aggregated data
   cntplotspecs <- aggspec(rspecdata, by = by, FUN = FUN.center)
   errplotspecs <- aggspec(rspecdata, by = by, FUN = FUN.error)
@@ -143,7 +142,7 @@ aggplot <- function(rspecdata, by = NULL, FUN.center = mean, FUN.error = sd,
     "#FF7F00", "#FFFF33", "#A65628", "#F781BF"
   )
 
-  col_list <- rep(col_list, length.out = dim(cntplotspecs)[2])
+  col_list <- rep_len(col_list, dim(cntplotspecs)[2])
 
   if (is.null(shadecol)) {
     shadecol <- col_list

R/aggspec.R

@@ -43,10 +43,8 @@ aggspec <- function(rspecdata, by = NULL, FUN = mean, trim = TRUE) {
     return(res)
   }
 
-  if (is.numeric(by)) {
-    if (ncol(y) %% by != 0) {
-      stop("by not a multiple of number of spectra")
-    }
+  if (is.numeric(by) && ncol(y) %% by != 0) {
+    stop("by not a multiple of number of spectra", call. = FALSE)
   }
 
   # Check if the by argument has a 'wl' entry (e.g. if names were obtained
@@ -65,11 +63,10 @@ aggspec <- function(rspecdata, by = NULL, FUN = mean, trim = TRUE) {
       by[id] <- lapply(by[id], "[", -unlist(wl_id)[id])
     }
     # check that wl column is the same for all vectors
-    if (length(unique(wl_id)) == 1) {
-      by <- do.call("paste", c(by, sep = "."))
-    } else {
-      stop("mismatch in column names of input vectors")
+    if (length(unique(wl_id)) != 1) {
+      stop("mismatch in column names of input vectors", call. = FALSE)
     }
+    by <- do.call("paste", c(by, sep = "."))
   }
 
   # retain original 'by' values
@@ -88,7 +85,8 @@ aggspec <- function(rspecdata, by = NULL, FUN = mean, trim = TRUE) {
     stop(
       dQuote(deparse(substitute(by))),
       " is not of same length as columns in ",
-      dQuote(deparse(substitute(data)))
+      dQuote(deparse(substitute(data))),
+      call. = FALSE
     )
   }