Nothing
#' @title Collect radial measurements from a calcified structure by interactively selecting annuli
#'
#' @description The user interactively select points on an image of a calcified structure. When finished, radial measurements (from the structure focus to the selected points) are calculated (either with arbitrary units or actual units if a scale-bar is included on the image) and written to an external file for later use.
#'
#' @param img A vector of strings that indicates the image (must be PNG, JPG, BMP, or TIFF) to be loaded and plotted. By default the user will be provided a dialog box from which to choose the file(s). Alternatively the user can supply the name(s) of the file(s). Either way the file(s) must be in the current working directory.
#' @param id A vector of unique identifiers for the fish or structure(s) being examined. Will be coerced to a character. If length of \code{img} is greater than 1, then the length of \code{id} must be the same. If missing then you will be prompted to enter a value.
#' @param reading See details in \code{\link{RFBCoptions}}.
#' @param description See details in \code{\link{RFBCoptions}}.
#' @param suffix See details in \code{\link{RFBCoptions}}.
#' @param edgeIsAnnulus See details in \code{\link{RFBCoptions}}.
#' @param windowSize See details in \code{\link{RFBCoptions}}.
#' @param deviceType See details in \code{\link{RFBCoptions}}.
#' @param closeWindow See details in \code{\link{RFBCoptions}}.
#' @param popID See details in \code{\link{RFBCoptions}}.
#' @param IDpattern See details in \code{\link{RFBCoptions}}.
#' @param IDreplace See details in \code{\link{RFBCoptions}}.
#' @param scaleBar See details in \code{\link{RFBCoptions}}.
#' @param scaleBarLength See details in \code{\link{RFBCoptions}}.
#' @param scaleBarUnits See details in \code{\link{RFBCoptions}}.
#' @param col.scaleBar See details in \code{\link{RFBCoptions}}.
#' @param lwd.scaleBar See details in \code{\link{RFBCoptions}}.
#' @param scalingFactor See details in \code{\link{RFBCoptions}}.
#' @param makeTransect See details in \code{\link{RFBCoptions}}.
#' @param snap2Transect See details in \code{\link{RFBCoptions}}.
#' @param col.transect See details in \code{\link{RFBCoptions}}.
#' @param lwd.transect See details in \code{\link{RFBCoptions}}.
#' @param pch.sel See details in \code{\link{RFBCoptions}}.
#' @param col.sel See details in \code{\link{RFBCoptions}}.
#' @param cex.sel See details in \code{\link{RFBCoptions}}.
#' @param pch.del See details in \code{\link{RFBCoptions}}.
#' @param col.del See details in \code{\link{RFBCoptions}}.
#' @param showInfo See details in \code{\link{RFBCoptions}}.
#' @param pos.info See details in \code{\link{RFBCoptions}}.
#' @param cex.info See details in \code{\link{RFBCoptions}}.
#' @param col.info See details in \code{\link{RFBCoptions}}.
#' @param addNote See details in \code{\link{RFBCoptions}}.
#' @param note A specific note about this reading (e.g., a note that the image was poor, some annulus were suspect, or the image should be re-read.). If missing then the user will be prompted to include a note if \code{addNote=TRUE}.
#'
#' @return \code{NULL} if more than one file was given in \code{img} or, if only one file was given, a list that contains the following:
#' \itemize{
#' \item{\code{image}: }{The full filename given in \code{img}.}
#' \item{\code{datanm}: }{The R data filename.}
#' \item{\code{description}: }{The description given in \code{description}.}
#' \item{\code{edgeIsAnnulus}: }{The logical given in \code{edgeIsAnnulus} that identified whether the structure edge/margin should be considered as an annulus.}
#' \item{\code{snap2Transect}: }{The logical from \code{snap2Transect} that identified whether the selected points were \dQuote{snapped} to the transect or not.}
#' \item{\code{scalingFactor}: }{A single numeric used to convert measurements on the structure image to actual measurements on the structure. Measurements on the structure image were multiplied by this value.}
#' \item{\code{sfSource}: }{A character string that identifies whether the scaling factor was \code{"Provided"} through the \code{scalingFactor} argument or derived from a \code{"scaleBar"}.}
#' \item{\code{sbPts}: }{A data.frame of \code{x} and \code{y} coordinates for the endpoints of the scale-bar if the scaling factor was derived from a scale-bar.}
#' \item{\code{sbLength}: }{A single numeric that is the known (actual) length of the scale-bar if the scaling factor was derived from a scale-bar.}
#' \item{\code{sbUnits}: }{A single character that is the units of measurement for the known (actual) length of the scale-bar if the scaling factor was derived from a scale-bar.}
#' \item{\code{slpTransect}: }{The slope of the transect.}
#' \item{\code{intTransect}: }{The intercept of the transect.}
#' \item{\code{slpPerpTransect}: }{The slope of the line perpendicular to the transect.}
#' \item{\code{windowSize}: }{A numeric of length two that contains the width and height of the window used to display the structure image. One of these units was set by the given \code{windowSize} value.}
#' \item{\code{pixW2H}: }{The ratio of pixel width to height. This is used to correct measurements for when an image is not square.}
#' \item{\code{pts}: }{A data.frame that contains the \code{x} and \code{y} coordinates on the image for the selected annuli. These points may have been \dQuote{snapped} to the transect if \code{snap2Transect==TRUE}.}
#' \item{\code{radii}: }{A data.frame that contains the unique \code{id}, the \code{reading} code, the age-at-capture in \code{agecap}, the annulus number in \code{ann}, the radial measurements in \code{rad}, and the radial measurement at capture in \code{radcap}.}
#' \item{\code{note}: }{A string that contains a note about the reading (e.g., a note that the image was poor, some annulus were suspect, or the image should be re-read.)}
#' }.
#'
#' @details This function requires interaction from the user. A detailed description of its use is in the vignettes on the \href{https://fishr-core-team.github.io/RFishBC/index.html}{RFishBC website}.
#'
#' @seealso \code{\link{showDigitizedImage}} and \code{\link{RFBCoptions}}.
#'
#' @author Derek H. Ogle, \email{derek@@derekogle.com}.
#'
#' @export
#'
#' @examples
#' ## None because this requires interaction from the user.
#' ## See the link to the extensive documentation in the Details.
#'
digitizeRadii <- function(img,id,reading,suffix,
description,edgeIsAnnulus,popID,IDpattern,IDreplace,
windowSize,deviceType,closeWindow,
scaleBar,scaleBarLength,scaleBarUnits,
col.scaleBar,lwd.scaleBar,
scalingFactor,makeTransect,snap2Transect,
col.transect,lwd.transect,
pch.sel,col.sel,cex.sel,
pch.del,col.del,
showInfo,pos.info,cex.info,col.info,
addNote,note) {
## Process argument defaults =================================================
if (missing(reading)) reading <- iGetopt("reading")
if (missing(description)) description <- iGetopt("description")
if (missing(suffix)) suffix <- iGetopt("suffix")
if (is.null(suffix) & !is.null(reading)) suffix <- reading # nocov
if (missing(edgeIsAnnulus)) edgeIsAnnulus <- iGetopt("edgeIsAnnulus")
if (!is.logical(edgeIsAnnulus))
STOP("'edgeIsAnnulus' must be TRUE or FALSE.")
if (missing(popID)) popID <- iGetopt("popID")
if (missing(IDpattern)) IDpattern <- iGetopt("IDpattern")
if (missing(IDreplace)) IDreplace <- iGetopt("IDreplace")
if (missing(scaleBar)) scaleBar <- iGetopt("scaleBar")
if (missing(scaleBarLength)) scaleBarLength <- iGetopt("scaleBarLength")
if (missing(scaleBarUnits)) scaleBarUnits <- iGetopt("scaleBarUnits")
if (missing(scalingFactor)) scalingFactor <- iGetopt("scalingFactor")
if (scaleBar & is.null(scaleBarLength))
STOP("Must provide a 'scaleBarLength' when 'scaleBar=TRUE'.")
if (scaleBar & is.null(scaleBarUnits))
STOP("Must provide a 'scaleBarUnits' when 'scaleBar=TRUE'.")
if (!is.null(scaleBarLength)) {
if (!is.numeric(scaleBarLength)) STOP("'scaleBarLength' must be numeric.")
if (scaleBarLength<=0) STOP("'scaleBarLength' must be positive.")
if (scalingFactor!=RFBCoptions()$scalingFactor)
STOP("Can not set both 'scaleBarLength' and 'scalingFactor'.")
}
if (!is.null(scaleBarUnits)) {
if (!is.character(scaleBarUnits)) STOP("'scaleBarUnits' must be a character.")
}
if (!scaleBar & !is.null(scaleBarLength))
STOP("Can not use 'scaleBarLength=' with 'scaleBar=FALSE'.")
if (!scaleBar & !is.null(scaleBarUnits))
STOP("Can not use 'scaleBarUnits=' with 'scaleBar=FALSE'.")
if (!is.null(scalingFactor)) {
if (!is.numeric(scalingFactor)) STOP("'scalingFactor' must be numeric.")
if (scalingFactor<=0) STOP("'scalingFactor' must be positive.")
}
if (missing(col.scaleBar)) col.scaleBar <- iGetopt("col.scaleBar")
if (length(col.scaleBar)>1) STOP("Can use only one color in 'col.scaleBar='.")
if (missing(lwd.scaleBar)) lwd.scaleBar <- iGetopt("lwd.scaleBar")
if (length(lwd.scaleBar)>1) STOP("Can use only one value in 'lwd.scaleBar='.")
if (missing(makeTransect)) makeTransect<- iGetopt("makeTransect")
if (missing(snap2Transect)) snap2Transect<- iGetopt("snap2Transect")
if (snap2Transect & !makeTransect) {
snap2Transect <- makeTransect
message("\n!! 'snap2Transect' changed to 'FALSE'",
" because 'makeTransect=FALSE'.\n\n")
}
if (missing(col.transect)) col.transect <- iGetopt("col.transect")
if (length(col.transect)>1) STOP("Can use only one color in 'col.transect='.")
if (missing(lwd.transect)) lwd.transect <- iGetopt("lwd.transect")
if (length(lwd.transect)>1) STOP("Can use only one value in 'lwd.transect='.")
if (missing(pch.sel)) pch.sel <- iGetopt("pch.sel")
if (missing(col.sel)) col.sel <- iGetopt("col.sel")
if (missing(cex.sel)) cex.sel <- iGetopt("cex.sel")
if (missing(pch.del)) pch.del <- iGetopt("pch.del")
if (missing(col.del)) col.del <- iGetopt("col.del")
if (missing(windowSize)) windowSize <- iGetopt("windowSize")
if (!is.numeric(windowSize)) STOP("'windowSize' must be numeric.")
if (windowSize<=0) STOP("'windowSize' must be positive.")
if (missing(deviceType)) deviceType <- iGetopt("deviceType")
if (missing(closeWindow)) closeWindow <- iGetopt("closeWindow")
if (missing(showInfo)) showInfo <- iGetopt("showInfo")
if (missing(pos.info)) pos.info <- iGetopt("pos.info")
if (missing(cex.info)) cex.info <- iGetopt("cex.info")
if (missing(col.info)) col.info <- iGetopt("col.info")
if (missing(addNote)) addNote <- iGetopt("addNote")
if (missing(note)) note <- ""
## Handle getting the image filename =========================================
img <- iHndlFilenames(img,filter="images",multi=TRUE)
## Handle the ID =============================================================
if (missing(id)) { # nocov start
## Guess IDs from image file names
initID <- tryCatch(getID(img,IDpattern,IDreplace),
error=function(e) tools::file_path_sans_ext(img))
## If only one image then ask user to enter ID,
if (length(img)==1) {
if (grepl('w|W', .Platform$OS.type)) {
## we are on Windows ... use a windows dialog box
## use img name as the default if popID=TRUE
id <- utils::winDialogString("Enter a unique ID: ",
ifelse(popID,initID,""))
} else {
## Not on Windows ... use prompt in console if in interactive session
if (interactive()) id <- readline(prompt="Enter a unique ID: ")
}
} else {
## Set ID to the initial guesses at IDs when multiple images given
id <- initID
} # nocov end
} else {
## Make sure that img and id have the same length
if (length(img)!=length(id))
STOP("Lengths of image file names and IDs must be equal.")
}
if (missing(id) | is.null(id)) STOP("You must provide a unique ID in 'id'.") # nocov
## ===========================================================================
if (length(img)>1) { # nocov start
## More than one image to process
for (i in seq_along(img)) {
digitizeRadii(img[i],id=id[i],reading,suffix,
description,edgeIsAnnulus,popID,IDpattern,IDreplace,
windowSize,deviceType,closeWindow,
scaleBar,scaleBarLength,scaleBarUnits,
col.scaleBar,lwd.scaleBar,
scalingFactor,makeTransect,snap2Transect,
col.transect,lwd.transect,
pch.sel,col.sel,cex.sel,
pch.del,col.del,
showInfo,pos.info,cex.info,col.info,
addNote,note)
}
dat <- NULL
} else {
## Only one image to process
dat <- iDigitizeRadii1(img,id,reading,suffix,
description,edgeIsAnnulus,popID,IDpattern,IDreplace,
windowSize,deviceType,
scaleBar,scaleBarLength,scaleBarUnits,
col.scaleBar,lwd.scaleBar,
scalingFactor,makeTransect,snap2Transect,
col.transect,lwd.transect,
pch.sel,col.sel,cex.sel,
pch.del,col.del,
showInfo,pos.info,cex.info,col.info,
addNote,note)
if (closeWindow) grDevices::dev.off()
}
invisible(dat)
} # nocov end
########################################################################
## =====================================================================
## INTERNAL FUNCTIONS specific to digitizeRadii()
## others shared with other functions in RFishBC-internals
## =====================================================================
########################################################################
########################################################################
## Digitize one image
########################################################################
iDigitizeRadii1 <- function(img,id,reading,suffix,
description,edgeIsAnnulus,popID,IDpattern,IDreplace,
windowSize,deviceType,
scaleBar,scaleBarLength,scaleBarUnits,
col.scaleBar,lwd.scaleBar,
scalingFactor,makeTransect,snap2Transect,
col.transect,lwd.transect,
pch.sel,col.sel,cex.sel,
pch.del,col.del,
showInfo,pos.info,cex.info,col.info,
addNote,note) { # nocov start
## Setup logicals that allow an abort or a restart ===========================
abort <- restart <- killed <- FALSE
## Setup a message ===========================================================
msg2 <- " 'f'=finished, 'd'=delete, 'q'=abort, 'z'=restart, 'k'=kill"
## Loads image given in img ==================================================
windowInfo <- iGetImage(img,id,windowSize,deviceType,
showInfo,pos.info,cex.info,col.info)
DONE("Loaded ",img,".\n")
## Allows user to select a scaling bar to get a scaling factor ===============
if (scaleBar) { ## scaleBar is on the plot
RULE("Select endpoints of scale-bar.")
RULE(msg2,line="-")
sfSource <- "scaleBar"
sbInfo <- iScalingFactorFromScaleBar(msg2,scaleBarLength,
windowInfo$pixW2H,
col.scaleBar=col.scaleBar,
lwd.scaleBar=lwd.scaleBar,
pch.sel=pch.sel,col.sel=col.sel,
cex.sel=cex.sel,
pch.del=pch.del,col.del=col.del)
if (is.list(sbInfo)) { # returned a list b/c not abort/restarted
sbPts <- sbInfo$sbPts
scalingFactor <- sbInfo$scalingFactor
DONE("Found scaling factor from selected scale-bar.\n")
} else { # no list returned b/c abort/restarted/killed
if (sbInfo=="ABORT") abort <- TRUE
else if (sbInfo=="RESTART") restart <- TRUE
else if (sbInfo=="KILLED") killed <- TRUE
}
} else { ## No scale bar on the plot ... using the scaling factor
DONE("Using scaling factor provided in 'scalingFactor'.\n")
sbPts <- NULL
scaleBarLength <- NULL
sfSource <- "Provided"
}
## User selects a transect on the image ======================================
if (!makeTransect) {
slpTransect <- intTransect <- slpPerpTransect <- trans.pts <- NULL
} else if (!abort & !restart & !killed) {
RULE("Select FOCUS (center) and MARGIN (edge) of the structure.")
RULE(msg2,line="-")
trans.pts <- iSelectPt(2,"Select FOCUS and MARGIN:",msg2,
pch.sel=pch.sel,col.sel=col.sel,cex.sel=cex.sel,
pch.del=pch.del,col.del=col.del,
snap2Transect=FALSE,trans.pts=NULL,slpTransect=NULL,
intTransect=NULL,slpPerpTransect=NULL)
if (is.data.frame(trans.pts)) { # returned data.frame b/c not abort/restarted
#### Calculate slope, intercept, and perpendicular slope to transect
slpTransect <- diff(trans.pts$y)/diff(trans.pts$x)
intTransect <- trans.pts$y[1]-slpTransect*trans.pts$x[1]
slpPerpTransect <- -1/slpTransect
#### Show the transect if asked to
if (makeTransect) {
graphics::lines(y~x,data=trans.pts,lwd=lwd.transect,col=col.transect)
DONE("Transect selected and shown on image.\n")
} else {
DONE("Transect selected.\n")
}
} else { # no data.frame returned b/c abort/restarted/killed
if (trans.pts=="ABORT") abort <- TRUE
else if (trans.pts=="RESTART") restart <- TRUE
else if (trans.pts=="KILLED") killed <- TRUE
}
}
## User selects annuli on the image ==========================================
if (!abort & !restart & !killed) {
RULE(ifelse(makeTransect,"Select points that are annuli.",
"Select FOCUS, then ANNULI, and then MARGIN."))
RULE(msg2,line="-")
pts <- iSelectPt(NULL,ifelse(makeTransect,"Select ANNULI:","Select POINTS"),
msg2,pch.sel=pch.sel,col.sel=col.sel,cex.sel=cex.sel,
pch.del=pch.del,col.del=col.del,
snap2Transect=snap2Transect,trans.pts=trans.pts,
slpTransect=slpTransect,intTransect=intTransect,
slpPerpTransect=slpPerpTransect)
if (is.data.frame(pts)) { # data.frame returned b/c not abort/restarted
#### Add transect (focus and margin) to the points
pts <- rbind(trans.pts,pts)
#### Re-order points by distance from the first point (the focus)
pts <- iOrderPts(pts,edgeIsAnnulus)
numAnn <- nrow(pts)-2
if (edgeIsAnnulus) numAnn <- numAnn+1
#### Tell the user how many points were selected
if (numAnn==1) DONE("1 point was selected as an annulus.\n")
else DONE(numAnn," points were selected as annuli.\n")
} else { # data.frame not returned because abort/restarted/killed
if (pts=="ABORT") abort <- TRUE
else if (pts=="RESTART") restart <- TRUE
else if (pts=="KILLED") killed <- TRUE
}
}
## Converts selected points to radial measurements ===========================
## as long as not aborted or asked to restart =============================
if (!abort & !restart & !killed) {
radii <- iPts2Rad(pts,edgeIsAnnulus=edgeIsAnnulus,scalingFactor=scalingFactor,
pixW2H=windowInfo$pixW2H,id=id,reading=reading)
}
## Finish up =================================================================
if (killed) {
## send a message
cat("\n\n")
DONE2("Entire processing was ABORTED by user! No file was written for ",img,".\n")
## close the image window
grDevices::dev.off()
## stop further functioning ... but do it quietly and thus, more elegantly
opt <- options(show.error.messages=FALSE)
on.exit(options(opt))
stop()
} else if (abort) {
cat("\n\n")
DONE2("Processing of image was ABORTED by user! No file written for ",img,".\n")
} else if (restart) {
cat("\n\n")
DONE2("Processing is being RESTARTED as requested by user.",
" No file written for ",img,".\n\n")
iDigitizeRadii1(img,id,reading,suffix,description,edgeIsAnnulus,popID,
IDpattern,IDreplace,windowSize,deviceType,scaleBar,
scaleBarLength,scaleBarUnits,col.scaleBar,lwd.scaleBar,
scalingFactor,makeTransect,snap2Transect,col.transect,
lwd.transect,pch.sel,col.sel,cex.sel,pch.del,col.del,
showInfo,pos.info,cex.info,col.info,addNote,note)
} else { ### process results because not abort/restarted
### Create a master data object and write to RData file in working directory
#### Name of RData file
datanm <- paste0(tools::file_path_sans_ext(img),
ifelse(!is.null(suffix),"_",""),
suffix,".rds")
#### Add a note (if asked to do so)
if (addNote & note=="") note <- iGetNote(note)
#### Master data object
dat <- list(image=img,datanm=datanm,description=description,
edgeIsAnnulus=edgeIsAnnulus,snap2Transect=snap2Transect,
scalingFactor=scalingFactor,sfSource=sfSource,
sbPts=sbPts,sbLength=scaleBarLength,sbUnits=scaleBarUnits,
slpTransect=slpTransect,intTransect=intTransect,
slpPerpTransect=slpPerpTransect,
windowSize=windowInfo$windowSize,
pixW2H=windowInfo$pixW2H,
pts=pts,radii=radii,note=note)
#### Make RFishBC class
class(dat) <- "RFishBC"
#### Write the RData file
saveRDS(dat,file=datanm)
#### Tell user what happend and invisibly return the R object
DONE("Results written to ",datanm,".\n\n")
invisible(dat)
}
} # nocov end
########################################################################
## Convert selected x-y points to radial measurements
########################################################################
iPts2Rad <- function(pts,edgeIsAnnulus,scalingFactor,pixW2H,id,reading) {
#### Number of radial measurements is one less than number of points selected
n <- nrow(pts)-1
#### Distances in x- and y- directions, corrected for pixel w to h ratio
distx <- diff(pts$x)*pixW2H
disty <- diff(pts$y)
#### Distances between points
distxy <- sqrt(distx^2+disty^2)
#### Correct distances for scalingFactor ... and call an increment
inc <- distxy*scalingFactor
#### Radii is cumulative sum of increments
rad <- cumsum(inc)
#### create data.frame with radii information
data.frame(id=as.character(rep(id,n)),
reading=as.character(rep(ifelse(is.null(reading),NA,reading),n)),
agecap=ifelse(edgeIsAnnulus,n,n-1),
ann=seq_len(n),rad=rad,radcap=max(rad),
stringsAsFactors=FALSE)
}
########################################################################
## Snaps selected points to the transect
##
## Perpendicularly "slides" a point to fall on the transect.
########################################################################
iSnap2Transect <- function(pts,trans.pts,
slpTransect,intTransect,slpPerpTransect) { # nocov start
if (is.infinite(slpTransect)) {
## Transect is perfectly vertical
### x-value of point of intercept with transect is same as x on transect
intersectsX <- trans.pts$x
### y-value of point of intercept with transect is same as y of point
intersectsY <- pts$y
} else if (isTRUE(all.equal(slpTransect,0))) {
## Transect is perfectly horizontal
### x-value of point of intercept with transect is same as x of point
intersectsX <- pts$x
### y-value of point of intercept with transect is same as y on transect
intersectsY <- trans.pts$y
} else {
## Transect is not perfectly vertical, so must be careful with geometry
### Intercept of line perpendicular to transect through the point.
intPerp <- pts$y-slpPerpTransect*pts$x
### Intersection between transect and perpendicular line through the point
intersectsX <- (intPerp-intTransect)/(slpTransect-slpPerpTransect)
intersectsY <- intTransect+slpTransect*intersectsX
}
### Return snapped coordinates
data.frame(x=intersectsX,y=intersectsY)
} # nocov end
########################################################################
## Orders a data.frame of x-y coordinates by distance from first point.
########################################################################
iOrderPts <- function(pts,edgeIsAnnulus) {
## find a matrix of distances from the first point (in the first column
## returned by dist()), finds the order of those distances, and re-orders
## the original points by that order and returns the result
pts <- pts[order(as.matrix(stats::dist(pts))[,1]),]
## change rownames
rownames(pts) <- c("center",1:(nrow(pts)-1))
if (!edgeIsAnnulus) rownames(pts)[nrow(pts)] <- "edge"
## Return data.frame
pts
}
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.