Merge pull request #161 from wincowgerDEV/streamline-identification

Streamlined file sharing.

DESCRIPTION

@@ -81,7 +81,7 @@ Imports:
     osfr,
     caTools,
     hyperSpec,
-    imager,
+    mmand,
     plotly,
     digest,
     signal,

NAMESPACE

@@ -14,6 +14,8 @@ S3method(as_OpenSpecy,list)
 S3method(c_spec,OpenSpecy)
 S3method(c_spec,default)
 S3method(c_spec,list)
+S3method(calc_window_points,OpenSpecy)
+S3method(calc_window_points,default)
 S3method(collapse_spec,OpenSpecy)
 S3method(collapse_spec,default)
 S3method(conform_spec,OpenSpecy)
@@ -22,6 +24,8 @@ S3method(cor_spec,OpenSpecy)
 S3method(cor_spec,default)
 S3method(def_features,OpenSpecy)
 S3method(def_features,default)
+S3method(fill_spec,OpenSpecy)
+S3method(fill_spec,default)
 S3method(filter_spec,OpenSpecy)
 S3method(filter_spec,default)
 S3method(flatten_range,OpenSpecy)
@@ -38,6 +42,8 @@ S3method(make_rel,OpenSpecy)
 S3method(make_rel,default)
 S3method(match_spec,OpenSpecy)
 S3method(match_spec,default)
+S3method(os_similarity,OpenSpecy)
+S3method(os_similarity,default)
 S3method(plot,OpenSpecy)
 S3method(plotly_spec,OpenSpecy)
 S3method(plotly_spec,default)
@@ -69,13 +75,15 @@ export(ai_classify)
 export(as_OpenSpecy)
 export(as_hyperSpec)
 export(c_spec)
+export(calc_window_points)
 export(check_OpenSpecy)
 export(check_lib)
 export(collapse_spec)
 export(conform_res)
 export(conform_spec)
 export(cor_spec)
 export(def_features)
+export(fill_spec)
 export(filter_spec)
 export(flatten_range)
 export(gen_grid)
@@ -92,6 +100,7 @@ export(make_rel)
 export(match_spec)
 export(max_cor_named)
 export(mean_replace)
+export(os_similarity)
 export(plotly_spec)
 export(process_spec)
 export(read_any)
@@ -114,6 +123,7 @@ export(share_spec)
 export(sig_noise)
 export(smooth_intens)
 export(spec_res)
+export(split_spec)
 export(subtr_baseline)
 export(write_spec)
 importFrom(caTools,read.ENVI)
@@ -125,6 +135,7 @@ importFrom(data.table,dcast)
 importFrom(data.table,fifelse)
 importFrom(data.table,fread)
 importFrom(data.table,frollapply)
+importFrom(data.table,fwrite)
 importFrom(data.table,is.data.table)
 importFrom(data.table,melt)
 importFrom(data.table,rbindlist)
@@ -138,11 +149,12 @@ importFrom(graphics,matlines)
 importFrom(graphics,matplot)
 importFrom(hyperSpec,read.jdx)
 importFrom(hyperSpec,read.spc)
-importFrom(imager,as.cimg)
-importFrom(imager,label)
 importFrom(jsonlite,read_json)
 importFrom(jsonlite,write_json)
 importFrom(methods,new)
+importFrom(mmand,components)
+importFrom(mmand,gaussianSmooth)
+importFrom(mmand,shapeKernel)
 importFrom(osfr,osf_download)
 importFrom(osfr,osf_ls_files)
 importFrom(osfr,osf_retrieve_node)
@@ -162,6 +174,7 @@ importFrom(stats,lm)
 importFrom(stats,median)
 importFrom(stats,model.frame)
 importFrom(stats,poly)
+importFrom(stats,prcomp)
 importFrom(stats,predict)
 importFrom(stats,sd)
 importFrom(stats,setNames)

R/adj_intens.R

@@ -58,6 +58,10 @@ adj_intens.default <- function(x, ...) {
 #'
 #' @export
 adj_intens.OpenSpecy <- function(x, type = "none", make_rel = TRUE, ...) {
+
+  if(!type %in% c("none", "transmittance", "reflectance")) 
+      stop('type argument must be one of "none", "transmittance", or "reflectance"')
+
   spec <- x$spectra
 
   adj <- switch(type,

R/as_OpenSpecy.R

@@ -14,7 +14,7 @@
 #' @param metadata metadata for each spectrum with one row per spectrum,
 #' see details.
 #' @param attributes a list of attributes describing critical aspects for interpreting the spectra.
-#' see details.
+#' see details. 
 #' @param coords spatial coordinates for the spectra.
 #' @param session_id logical. Whether to add a session ID to the metadata.
 #' The session ID is based on current session info so metadata of the same
@@ -104,6 +104,16 @@
 #'   \item{`baseline`}{supported options include `"raw"` or `"nobaseline"`}
 #'   \item{`spectra_type`}{supported options include `"ftir"` or `"raman"`}
 #' }
+#' 
+#' The \code{attributes} argument may contain a named list with the following
+#' details, when set, they will be used to automate transformations and warning messages:
+#'
+#' \tabular{ll}{
+#' \code{intensity_units}: \tab supported options include "absorbance", "transmittance", or "reflectance"\cr
+#' \code{derivative_order}: \tab supported options include "0", "1", or "2"\cr
+#' \code{baseline}: \tab supported options include "raw" or "nobaseline"\cr
+#' \code{spectra_type}: \tab supported options include "ftir" or "raman"\cr
+#' }
 #'
 #' @return
 #' \code{as_OpenSpecy()} and \code{OpenSpecy()} returns three part lists
@@ -261,9 +271,9 @@ as_OpenSpecy.default <- function(x, spectra,
                                    other_info = NULL,
                                    license = "CC BY-NC"),
                                  attributes = list(
-                                   intensity_unit = NULL,
-                                   derivative_order = NULL,
-                                   baseline = NULL,
+                                   intensity_unit = NULL, 
+                                   derivative_order = NULL, 
+                                   baseline = NULL, 
                                    spectra_type = NULL
                                  ),
                                  coords = "gen_grid",
@@ -282,29 +292,29 @@ as_OpenSpecy.default <- function(x, spectra,
   if (length(x) != nrow(spectra))
     stop("'x' and 'spectra' must be of equal length", call. = F)
 
-  obj <- structure(list(),
+  obj <- structure(list(), 
+
                    class = c("OpenSpecy", "list"),
                    intensity_unit = attributes$intensity_unit,
                    derivative_order = attributes$derivative_order,
                    baseline = attributes$baseline,
                    spectra_type = attributes$spectra_type
-  )
+                   )
+
 
   obj$wavenumber <- x[order(x)]
 
   obj$spectra <- as.data.table(spectra)[order(x)]
 
-  if (inherits(coords, "character")) {
+  if (inherits(coords, "character") && !any(is.element(c("x", "y"), names(metadata)))) {
     obj$metadata <- do.call(coords, list(ncol(obj$spectra)))
   } else if(inherits(coords, c("data.frame", "list")) &&
              all(is.element(c("x", "y"), names(coords)))) {
     obj$metadata <- as.data.table(coords)
-  } else if(is.null(coords)){
+  } else {
+    if(!all(is.element(c("x", "y"), names(metadata))))  stop("inconsistent input for 'coords'", call. = F)
     obj$metadata <- data.table()
   }
-  else {
-    stop("inconsistent input for 'coords'", call. = F)
-  }
   if (!is.null(metadata)) {
     if (inherits(metadata, c("data.frame", "list"))) {
       obj$metadata <- cbind(obj$metadata, as.data.table(metadata))

R/conform_spec.R

@@ -10,9 +10,15 @@
 #' min and max value.
 #' @param res spectral resolution adjusted to or \code{NULL} if the raw range
 #' should be used.
+#' @param allow_na logical; should NA values in places beyond the wavenumbers 
+#' of the dataset be allowed?
 #' @param type the type of wavenumber adjustment to make. \code{"interp"}
 #' results in linear interpolation while \code{"roll"} conducts a nearest
-#' rolling join of the wavenumbers.
+#' rolling join of the wavenumbers. \code{"mean_up"} only works when
+#' Spectra are being aggregated, we take the mean of the intensities within the 
+#' wavenumber specified. This can maintain smaller peaks and make spectra more
+#' similar to it's less resolved relatives. mean_up option is still experimental.
+#' 
 #' @param \ldots further arguments passed to \code{\link[stats]{approx}()}
 #'
 #' @return
@@ -47,18 +53,18 @@ conform_spec.default <- function(x, ...) {
 #' @rdname conform_spec
 #'
 #' @export
-conform_spec.OpenSpecy <- function(x, range = NULL, res = 5, type = "interp",
+conform_spec.OpenSpecy <- function(x, range = NULL, res = 5, allow_na = F, type = "interp",
                                    ...) {
-  if(!any(type %in% c("interp", "roll")))
-    stop("type must be either interp or roll")
+  if(!any(type %in% c("interp", "roll", "mean_up")))
+    stop("type must be either interp, roll, or mean_up")
 
   if(is.null(range)) range <- x$wavenumber
 
   if(!is.null(res)) {
-    range <- c(max(min(range), min(x$wavenumber)),
+    range2 <- c(max(min(range), min(x$wavenumber)),
                min(max(range), max(x$wavenumber)))
 
-    wn <- conform_res(range, res = res)
+    wn <- conform_res(range2, res = res)
   } else {
     wn <- range[range >= min(x$wavenumber) & range <= max(x$wavenumber)]
   }
@@ -75,7 +81,26 @@ conform_spec.OpenSpecy <- function(x, range = NULL, res = 5, type = "interp",
     spec <- spec[join, roll = "nearest", on = "wavenumber"]
     spec <- spec[,-"wavenumber"]
   }
-
+
+  if(type == "mean_up"){
+      spec <- x$spectra[,lapply(.SD, mean), 
+                                   by = cut(x = x$wavenumber, breaks = wn)][,-"cut"]
+  }
+
+  if(allow_na){
+      if(min(range) < min(wn) | max(range) > max(wn)){
+          if(!is.null(res)){
+              filler_range  <- conform_res(range, res = res)
+          }
+          else{
+              filler_range <- range
+          }
+          filler = data.table("wavenumber" = filler_range)
+          spec <- spec[,"wavenumber" := wn][filler, on = "wavenumber"][,-"wavenumber"]
+          wn <- filler_range
+      }
+  }
+
   x$wavenumber <- wn
   x$spectra <- spec
 

R/def_features.R

@@ -29,12 +29,16 @@
 #' spectra are of features (\code{TRUE}) and which are not (\code{FALSE}).
 #' If a character vector is provided, it should represent the different feature
 #' types present in the spectra.
+#' @param shape_kernel the width and height of the area in pixels to search for
+#' connecting features, c(3,3) is typically used but larger numbers will smooth
+#' connections between particles more. 
 #' @param \ldots additional arguments passed to subfunctions.
 #'
 #' @author
 #' Win Cowger, Zacharias Steinmetz
 #'
 #' @importFrom data.table data.table as.data.table setDT rbindlist transpose .SD :=
+#' @importFrom mmand shapeKernel components
 #' @export
 collapse_spec <- function(x, ...) {
   UseMethod("collapse_spec")
@@ -59,7 +63,7 @@ collapse_spec.OpenSpecy <- function(x, ...) {
 
   x$metadata <- x$metadata |>
     unique(by = c("feature_id", "area", "feret_max", "centroid_y",
-                  "centroid_x"))
+                  "centroid_x", "first_x", "first_y", "rand_x", "rand_y"))
 
   return(x)
 }
@@ -80,10 +84,9 @@ def_features.default <- function(x, ...) {
 
 #' @rdname def_features
 #'
-#' @importFrom imager label as.cimg
 #' @importFrom data.table as.data.table setDT rbindlist data.table
 #' @export
-def_features.OpenSpecy <- function(x, features, ...) {
+def_features.OpenSpecy <- function(x, features, shape_kernel = c(3,3), ...) {
   if(is.logical(features)) {
     if(all(features) | all(!features))
       stop("features cannot be all TRUE or FALSE because that would indicate ",
@@ -96,8 +99,8 @@ def_features.OpenSpecy <- function(x, features, ...) {
            "indicate that there are no distinct features", call. = F)
 
     features_df <- rbindlist(lapply(unique(features),
-                                    function(y) .def_features(x, features == y))
-    )
+                                    function(y) .def_features(x, features == y, name = y))
+    )[!endsWith(feature_id, "-88"),]
   } else {
     stop("features needs to be a character or logical vector", call. = F)
   }
@@ -109,19 +112,25 @@ def_features.OpenSpecy <- function(x, features, ...) {
   md[, feature_id := ifelse(is.na(feature_id), "-88", feature_id)]
   md[, "centroid_x" := mean(x), by = "feature_id"]
   md[, "centroid_y" := mean(y), by = "feature_id"]
-
+  md[, "first_x" := x[1], by = "feature_id"]
+  md[, "first_y" := y[1], by = "feature_id"]
+  md[, "rand_x" := sample(x,1), by = "feature_id"]
+  md[, "rand_y" := sample(y,1), by = "feature_id"]
+
   obj$metadata <- md
 
   return(obj)
 }
 
+
 #' @importFrom grDevices chull
 #' @importFrom stats dist
-.def_features <- function(x, binary, name = NULL) {
+.def_features <- function(x, binary, shape_kernel = c(3,3), name = NULL) {
   # Label connected components in the binary image
   binary_matrix <- matrix(binary, ncol = max(x$metadata$x) + 1, byrow = T)
-  labeled_image <- imager::label(imager::as.cimg(binary_matrix),
-                                 high_connectivity = T)
+
+  k <- shapeKernel(shape_kernel, type="box")
+  labeled_image <- components(binary_matrix, k)
 
   # Create a dataframe with feature IDs for each true pixel
   feature_points_dt <- data.table(x = x$metadata$x,
@@ -180,9 +189,12 @@ def_features.OpenSpecy <- function(x, features, ...) {
   }), fill = T)
 
   # Join with the coordinates from the binary image
-  if (!is.null(name)) {
-    features_dt$feature_id <- paste0(name, "_", features_dt$feature_id)
-  }
 
-  feature_points_dt[features_dt, on = "feature_id"]
+  feature_points_dt <- feature_points_dt[features_dt, on = "feature_id"]
+
+  if(!is.null(name)){
+      feature_points_dt$feature_id <- paste0(name, "_", feature_points_dt$feature_id)
+  }
+
+  feature_points_dt
 }