version 0.1.0

DESCRIPTION

@@ -0,0 +1,36 @@
+Package: densitr
+Title: Analysing Density Profiles from Resistance Drilling of Trees
+Version: 0.1.0
+Authors@R: c(
+    person(given = "Luka",
+    family = "Krajnc",
+    role = c("aut", "cre"),
+    email = "[email protected]",
+    comment = c(ORCID = "0000-0002-3120-559X")),
+    person(given = "Stasia",
+    family = "Grinberg",
+    role = c("ctb")))
+Description: Provides various tools for analysing density profiles
+    obtained by resistance drilling. It can load individual or
+    multiple files and trim the starting and ending part of each
+    density profile. Tools are also provided to trim profiles
+    manually, to remove the trend from measurements using several
+    methods, to plot the profiles and to detect tree rings
+    automatically. Written with a focus on forestry use of resistance
+    drilling in standing trees.
+License: GPL-3
+Encoding: UTF-8
+URL: https://github.com/krajnc/densitr
+BugReports: https://github.com/krajnc/densitr/issues
+LazyData: true
+Imports: stats, utils, changepoint (>= 2.2.2)
+Suggests: pbapply, mgcv, knitr, rmarkdown, testthat
+RoxygenNote: 7.1.0
+VignetteBuilder: knitr
+NeedsCompilation: no
+Packaged: 2020-04-06 09:11:18 UTC; [email protected]
+Author: Luka Krajnc [aut, cre] (<https://orcid.org/0000-0002-3120-559X>),
+  Stasia Grinberg [ctb]
+Maintainer: Luka Krajnc <[email protected]>
+Repository: CRAN
+Date/Publication: 2020-04-07 12:50:02 UTC

MD5

@@ -0,0 +1,70 @@
+2b6968351d06bba373d80d57a374d9ba *DESCRIPTION
+e0d9f3fd238e82772c3f7ce86ecb46c6 *NAMESPACE
+9c51f2b08826757e650938b1ba7a0546 *R/detect.R
+7c4c2a97ee05f72b21295265d30df5d6 *R/detrend.R
+264bca54c6d4ad200914553b339afd12 *R/generic.R
+5df5b8eabe3c5a9d7f49cabc11ef256e *R/load.R
+e6096defbd9b7cadb1897e09c9e6b540 *R/manual.R
+7ab7740505f7a652ce2ecb7bb126855c *R/other.R
+3446ec867787a02b2c4372ac931156c3 *R/plots.R
+22dcddce2e12a5934735b75b62a4f4bc *R/rw.R
+5a66f23c526357c99b2e619595e9d16a *R/trim.R
+6b5f1dd8c226bf3faedd8f26211dffaa *build/vignette.rds
+340a6a2d90666db3e3a70194ebcd8428 *inst/doc/Detrending_and_ring_widths.R
+f429a3fb482f3b95cea47e17a79938b2 *inst/doc/Detrending_and_ring_widths.Rmd
+8c31a9afeb2d6b118513dabf883fb311 *inst/doc/Detrending_and_ring_widths.html
+8beecfe9a06f11d510cb6a2e85830c4d *inst/doc/Loading_trimming_profiles.R
+e6c8cd3234188ea4eac66b24e856ebdc *inst/doc/Loading_trimming_profiles.Rmd
+cb41990ee9a31f5794055f0872aed738 *inst/doc/Loading_trimming_profiles.html
+e3ce1b58472df31e2dd79121cc4de5c6 *inst/doc/Manual_trimming.R
+864e2bb1120523a471dbf82c197b82b5 *inst/doc/Manual_trimming.Rmd
+e6445c8b24dbf5036e341ae14b5bdcab *inst/doc/Manual_trimming.html
+f3798aa47e5fda99320f90c06fb7da0c *inst/doc/Tree_rings.R
+6bf26e1812b748829661759ade5877eb *inst/doc/Tree_rings.Rmd
+c887653478583b5b06630a7ecf43bcfe *inst/doc/Tree_rings.html
+7e3a70c33e301a5ea43d0c5145d715ba *inst/extdata/00010001.dpa
+046eae5f53ac3266aa63596255c32d0d *inst/extdata/00010002.dpa
+d89e575ebcfce835a50afb8c0c8d4ab3 *inst/extdata/00010003.dpa
+a16e3260d0e6c7ce657e133747d54e27 *inst/extdata/00010004.dpa
+20e1c026cee86f443266badb341b22b5 *inst/extdata/00010005.dpa
+fa9e64c66b736e5a8fe103af1effcdf9 *inst/extdata/subfolder/00050045.dpa
+23728dd97c7b227d3c8eb03aa269efaf *inst/extdata/subfolder/00050046.dpa
+c86e69fde9a269df98898f5143536820 *inst/extdata/subfolder/00110012.dpa
+2363680bed9a8b64d15fdf765c703a7f *inst/extdata/subfolder/00110013.dpa
+f683483beb5b16e0cce21934bc629678 *inst/extdata/subfolder/00110014.dpa
+ecc2e1bf34e25317da25088933899522 *inst/extdata/subfolder/subsubfolder/00010006.dpa
+5541b8b1ab69060cbfbbe9a99ff751fe *inst/extdata/subfolder/subsubfolder/00050012.dpa
+6111e6970f7967e3ac124c9bce2fb904 *inst/extdata/subfolder/subsubfolder/00050013.dpa
+752337f8e0dd96b1d26f8ea891d9ed40 *inst/extdata/subfolder/subsubfolder/00050036.dpa
+c8ed88b345b6906e95385d6efa5e014e *inst/extdata/subfolder/subsubfolder/00050038.dpa
+80c8adc091916e636f6fffdd8395150f *man/combine_data.Rd
+97773f35cea7cf918953416f2a0fbfcb *man/combine_footers.Rd
+6369d7ea84d97748b33e4fcc0a1c0500 *man/correct_failures.Rd
+dc954187cdd8f928262c4f706b337534 *man/dpdetect_e.Rd
+26477b40485690850f913aed4c2bd16c *man/dpdetect_s.Rd
+3e68b1ae83b8425d7eed74c4c5304c52 *man/dpdetrend.Rd
+db5e028416a672584d8c1d81bd0f1e86 *man/dpload.Rd
+12a87ef859012163d2e9920c78011e43 *man/dprings.Rd
+306acfce1a01cf0175c90550141b7137 *man/dptrim.Rd
+654836a3179798d5be2a7316a7284480 *man/dptrim_s.Rd
+d9df16149a2fb777e082895f4cf0d6aa *man/dptriml.Rd
+ff1e329f97e9f1126ec2de45cae745cd *man/dptriml_s.Rd
+5645e38db6565e3a701b3f3d476b11e9 *man/extract_dpa_name.Rd
+e23b759bb198c86c9e3bc19afd5e842b *man/get_RW.Rd
+418324fc13ee0d071776cdd8624c34eb *man/manual_trim_detect.Rd
+48f6240233f242a063f690377ea04e22 *man/plot_all.Rd
+cd2f787bfb4165836fb4049bb145cc1b *man/plot_end_detection.Rd
+e037ab7b4c9c1e83c4ff9f9e04689e38 *man/plot_failures.Rd
+1b1e3901c014fd774c10c7cff07e4b7e *man/plot_start_detection.Rd
+2ae622dd5b8cfcf6b6bc9b06f0ad3a6b *man/plot_trimming.Rd
+3c973413f54e6b288f02a25bcf8ce8bf *man/read_dpa.Rd
+5e7d09a4304673eeafacc02aa5f8496d *man/remove_trim_failures.Rd
+3a1001e1d56101910fbedd84f9a97770 *man/separate_trim_failures.Rd
+8e2a8b56b12aa9f04e3601b83576a8c6 *tests/testthat.R
+31faf6e7f4dcbe4b2c478c1f9c4cea05 *tests/testthat/test_detection.R
+f09a29df77adacf936ee1a6faf1ac6a2 *tests/testthat/test_load.R
+88614901f3f4a1a6320824c2478dce3d *tests/testthat/test_trim.R
+f429a3fb482f3b95cea47e17a79938b2 *vignettes/Detrending_and_ring_widths.Rmd
+e6c8cd3234188ea4eac66b24e856ebdc *vignettes/Loading_trimming_profiles.Rmd
+864e2bb1120523a471dbf82c197b82b5 *vignettes/Manual_trimming.Rmd
+6bf26e1812b748829661759ade5877eb *vignettes/Tree_rings.Rmd

NAMESPACE

@@ -0,0 +1,25 @@
+# Generated by roxygen2: do not edit by hand
+
+S3method(plot,dp)
+S3method(print,dp)
+export(combine_data)
+export(combine_footers)
+export(correct_failures)
+export(dpdetect_e)
+export(dpdetect_s)
+export(dpdetrend)
+export(dpload)
+export(dprings)
+export(dptrim)
+export(dptrim_s)
+export(dptriml)
+export(dptriml_s)
+export(get_RW)
+export(manual_trim_detect)
+export(plot_all)
+export(plot_end_detection)
+export(plot_failures)
+export(plot_start_detection)
+export(plot_trimming)
+export(remove_trim_failures)
+export(separate_trim_failures)

R/detect.R

@@ -0,0 +1,216 @@
+#' Detect measurement starting point automatically using changepoint
+#' segmentation
+#'
+#' A typical resistance drilling measurement starts with an increase
+#' in resistance values in between the measurement start and the
+#' immersion of the needle in the wood. These values are not useful
+#' when estimating density and should be removed before further
+#' analysis. This function will detect the starting point
+#' automatically using binary segmentation from the package
+#' \code{changepoint}, which separates the measurement in segments
+#' based on their mean and variance. Start is detected, when the
+#' segment mean is outside of the cutoff limit, see \code{return.plot
+#' = TRUE} to display the diagnostic plot. This function will only
+#' check the mean values of the first four (4) segments and compare
+#' them to the cutoff value. The function is called on a dp object
+#' and returns either a row number of the starting point or a plot
+#' displaying the segmentation and detection. The sensitivity can be
+#' adjusted using the cutoff.sd parameter, which is an indicator on
+#' how many standard deviations the segment mean value can be before
+#' cutting it off. Will return a warning if start not detected.
+#' @param dp A dp object, see dpload.
+#' @param cutoff.sd How many standard deviations for the cutoff limit?
+#' @param return.plot If true, will return a plot displaying segment
+#'   detection for the current dp file.
+#' @return Either a row number where the actual measurement starts or
+#'   a plot, displaying changepoint segmentation and set limits.
+#' @seealso dpdetect_e, dptrim, dptriml, dptrim_s, dptriml_s
+#' @export
+#' @examples
+#' ## load a single file
+#' dp <- dpload(system.file("extdata", "00010001.dpa", package = "densitr"))
+#' ## get starting point
+#' start <- dpdetect_s(dp)
+#' ## plot the start detection
+#' \donttest{
+#' dpdetect_s(dp, return.plot = TRUE)
+#' }
+dpdetect_s <- function(dp, cutoff.sd = 1, return.plot = FALSE){
+  ## check if dp object
+  if (!inherits(dp,"dp")) {stop("not a dp object")}
+  ## get a rolling mean of diff lags
+  fit <- stats::loess(dp$data$amplitude ~ dp$data$position, span=0.1)
+  fitted <- stats::predict(fit)
+  data.in <- baseR.rollmean(diff(fitted),100) # defined in others.R
+  ## set limits and find segments
+  limit <- abs(mean(data.in) + (cutoff.sd * stats::sd(data.in)))
+  segments.points <- suppressWarnings(changepoint::cpt.meanvar(data.in,
+                                                               method="BinSeg", Q=10,
+                                                               minseglen=250,class=FALSE))
+  segments.list <- splitAt(data.in,segments.points)
+  segments.list[length(segments.list)] <- NULL  # remove the last item in a list
+  segment.value <- function(number){return(abs(mean(segments.list[[number]])))}
+  ## check the first four segments, if they are outside of the set,
+  ## limit and return the end positions of those segments
+  if (segment.value(4) < limit) {
+    if (segment.value(3) < limit) {
+      if (segment.value(2) < limit) {
+        if (segment.value(1) < limit) {
+          ## no segments found outside the limit in the first 4
+          ## segments
+          warning(paste("start not detected in measurement ",dp$footer$ID[1],sep="" ))
+          cutoff <- 1
+        } else {
+          cutoff <- segments.points[1]
+        }
+      } else {
+        ## return the position of the second segment, deleting the
+        ## first two
+        cutoff <- segments.points[2]
+      }
+    } else {
+      ## return the position of the third segment, deleting the first
+      ## three
+      cutoff <- segments.points[3]
+    }
+  } else {
+    ## return the position of the fourth segment, deleting the first
+    ## four segments
+    cutoff <- segments.points[4]
+  }
+  if (return.plot == TRUE) {
+    segments.points2 <- suppressWarnings(changepoint::cpt.meanvar(data.in,
+                                                                  method="BinSeg", Q=10,
+                                                                  minseglen=250,class=TRUE))
+    graphics::plot.new()
+    ## save and restore par setting
+    oldpar <-  graphics::par(no.readonly = TRUE)
+    on.exit(graphics::par(oldpar))
+    ## plot
+    graphics::par(mfrow=c(2,1))
+    graphics::plot(dp$data$amplitude, type = "l",
+                   xlab = paste0("Drilling depth [", dp$footer$xUnit, "]"),
+                   ylab= paste0("Resistograph density [", dp$footer$yUnit, "]"),
+                   main = paste0("Density profile ID: ",dp$footer$ID))
+    graphics::abline(v=cutoff, col="red",lwd=3, lty=2)
+    ## [1:length(dp$data$amplitude)/2]
+    changepoint::plot(segments.points2,
+                      xlab = paste0("Drilling depth [", dp$footer$xUnit, "]"),
+                      ylab= paste0("Moving average of lagged differences"),
+                      main="Detected segments")
+    graphics::abline(h=mean(data.in), col="blue")
+    graphics::abline(h=limit, col="green")
+    graphics::abline(v=cutoff, col="red", lwd=3, lty=2)
+    graphics::legend("topright", legend=c("Segment mean", "Overall mean", "Cutoff limit"),
+                     col=c("red", "blue", "green"), lty=1, cex=1)
+    p <- grDevices::recordPlot()
+    return(p)
+  } else {
+    return(cutoff) # add 100 to account for rolling mean right centered
+  }
+}
+
+#' Detect measurement ending point automatically using changepoint
+#' segmentation
+#'
+#' The opposite of the dpdetect_s, it will check the mean values
+#' of the last four segments and compare them to the cutoff limit.
+#' Will give a warning if end not detected, which is expected on
+#' measurements where the needle did not exit the tree on the opposite
+#' side of the tree. See \code{return.plot = TRUE} to display the
+#' actual process. The function is called on a dp object and returns
+#' either a row number of the measurement ending or a plot displaying
+#' the segmentation and detection. The sensitivity can be adjusted
+#' using the cutoff.sd parameter, which is an indicator on how many
+#' standard deviations the segment mean value can be before cutting it
+#' off.
+#' @param dp A dp object, see dpload.
+#' @param cutoff.sd How many standard deviations for the cutoff limit?
+#' @param return.plot If true, will return a plot displaying segment
+#'   detection for the current dp file.
+#' @return Either a row number where the actual measurement ends or
+#'   a plot, displaying changepoint segmentation and set limits.
+#' @seealso dpdetect_s, dptrim, dptriml, dptrim_s, dptriml_s
+#' @export
+#' @examples
+#' ## load a single file
+#' dp  <- dpload(system.file("extdata", "00010001.dpa", package = "densitr"))
+#' ## get ending point
+#' start <- dpdetect_e(dp)
+#' ## plot the end detection
+#' \donttest{
+#' dpdetect_e(dp, return.plot = TRUE)
+#' }
+dpdetect_e <- function(dp, cutoff.sd = 1, return.plot = FALSE){
+  ## check if dp object
+  if (!inherits(dp,"dp"))  {stop("not a dp object")}
+  ## get a rolling mean of diff lags
+  fit <- stats::loess(dp$data$amplitude ~ dp$data$position, span=0.1)
+  fitted <- stats::predict(fit)
+  data.in <- baseR.rollmean(diff(fitted),100) #defined in others.R
+  ## get limits and get segments
+  limit <- mean(data.in) - (cutoff.sd * stats::sd(data.in))
+  segments.points <- suppressWarnings(changepoint::cpt.meanvar(data.in,
+                                                               method="BinSeg", Q=10,
+                                                               minseglen=250,class=FALSE))
+  segments.list <- splitAt(data.in,segments.points)
+  segments.list[length(segments.list)] <- NULL  #remove the last item in a list
+  segment.value2 <- function(number){return(mean(segments.list[[length(segments.list)-number]]))}
+  if (segment.value2(3) < limit) {
+    ## delete the last 4 segments
+    cutoff <- segments.points[length(segments.points)-4]
+  } else {
+    if (segment.value2(2) < limit) {
+      ## delete the last 3 segments
+      cutoff <- segments.points[length(segments.points)-3]
+    } else {
+      if (segment.value2(1) < limit) {
+        ## delete the last 2 segments
+        cutoff <- segments.points[length(segments.points)-2]
+      } else {
+        if (segment.value2(0) < limit) {
+          ## delete the last segment
+          cutoff <- segments.points[length(segments.points)-1]
+        } else {
+          ## no segments deleted, no end detected
+          warning(paste("end not detected in file ",dp$footer$ID[1],sep="" ))
+          cutoff <- nrow(dp$data)
+        }
+      }
+    }
+  }
+  if (return.plot == TRUE) {
+    segments.points2 <- suppressWarnings(changepoint::cpt.meanvar(data.in,
+                                                                  method="BinSeg", Q=10,
+                                                                  minseglen=250,class=TRUE))
+    graphics::plot.new()
+    ## save and restore par setting
+    oldpar <-  graphics::par(no.readonly = TRUE)
+    on.exit(graphics::par(oldpar))
+    ## plot
+    graphics::par(mfrow=c(2,1))
+    graphics::plot(dp$data$amplitude, type = "l",
+                   xlab = paste0("Drilling depth [", dp$footer$xUnit[1], "]"),
+                   ylab= paste0("Resistograph density [", dp$footer$yUnit[1], "]"),
+                   main = paste0("Density profile ID: ",dp$footer$ID))
+    graphics::abline(v=cutoff + 100, col="red", lwd=3, lty=2)
+    changepoint::plot(segments.points2,
+                      xlab = paste0("Drilling depth [", dp$footer$xUnit[1], "]"),
+                      ylab= paste0("Moving average of lagged differences"),
+         main="Detected segments")
+    graphics::abline(h=mean(data.in), col="blue")
+    graphics::abline(h=limit, col="green")
+    graphics::abline(v=cutoff, col="red", lwd=3, lty=2)
+    graphics::legend("topright", legend=c("Segment mean", "Overall mean", "Cutoff limit"),
+                     col=c("red", "blue", "green"), lty=1, cex=1)
+    p <- grDevices::recordPlot()
+    return(p)
+  } else {
+    ## if end detected, add 100 to account for moving averages
+    if (cutoff == nrow(dp$data)) {
+      return(cutoff)
+    } else {
+      return(cutoff + 100)
+    }
+  }
+}