Nothing
#' @title Show points selected on a structure image and saved in an R data file
#'
#' @description Show points selected on a structure image to represent annuli that were saved to an R data file using \code{\link{digitizeRadii}}. This allows the user to reexamine the selected points or overlay selected points from multiple readings of the structure.
#'
#' @param nms A string (or vector of strings) that indicates the R data file(s) created with \code{\link{digitizeRadii}}. If missing the user will be provided a dialog box from which to choose the file(s). The file(s) must be in the current working directory (see \code{\link{getwd}} result). May also be a single \code{RFishBC} object created with \code{\link{digitizeRadii}}.
#' @param deviceType See details in \code{\link{RFBCoptions}}.
#' @param pch.show See details in \code{\link{RFBCoptions}}.
#' @param col.show See details in \code{\link{RFBCoptions}}.
#' @param cex.show See details in \code{\link{RFBCoptions}}.
#' @param connect See details in \code{\link{RFBCoptions}}.
#' @param col.connect See details in \code{\link{RFBCoptions}}.
#' @param lwd.connect 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 showScaleBarLength See details in \code{\link{RFBCoptions}}.
#' @param cex.scaleBar See details in \code{\link{RFBCoptions}}.
#' @param showAnnuliLabels See details in \code{\link{RFBCoptions}}.
#' @param annuliLabels See details in \code{\link{RFBCoptions}}.
#' @param col.ann See details in \code{\link{RFBCoptions}}.
#' @param cex.ann See details in \code{\link{RFBCoptions}}.
#' @param offset.ann See details in \code{\link{RFBCoptions}}.
#'
#' @return A list that contains the size of the window in \code{windowSize} and the pixel width to height ratio in \code{pixW2H}. In addition, an image is plotted with, at least, the selected points.
#'
#' @details This function requires interaction from the user. A detailed description of its use is in \href{https://fishr-core-team.github.io/RFishBC/articles/seeRadiiData.html}{this vignette} on the \href{https://fishr-core-team.github.io/RFishBC/index.html}{RFishBC website}.
#'
#' @seealso \code{\link{digitizeRadii}} and \code{\link{RFBCoptions}}.
#'
#' @author Derek H. Ogle, \email{DerekOgle51@gmail.com}
#'
#' @export
#'
#' @examples
#' ## None because this requires interaction from the user.
#' ## See the link to the extensive documentation in the Details.
#'
showDigitizedImage <- function(nms,deviceType,
pch.show,col.show,cex.show,
connect,col.connect,lwd.connect,
col.scaleBar,lwd.scaleBar,
showScaleBarLength,cex.scaleBar,
showAnnuliLabels,annuliLabels,
col.ann,cex.ann,offset.ann) {
## handle options
if (missing(deviceType)) deviceType <- iGetopt("deviceType")
if (missing(pch.show)) pch.show <- iGetopt("pch.show")
useArrows <- FALSE
if (is.character(pch.show)) {
if (length(pch.show)==1) {
if (pch.show=="arrows") useArrows <- TRUE
} else {
if (any(pch.show=="arrows"))
STOP("'arrows' cannot be used with other values in 'pch.show'.")
}
}
if (missing(col.show)) col.show <- iGetopt("col.show")
if (missing(cex.show)) cex.show <- iGetopt("cex.show")
if (missing(connect)) connect <- iGetopt("connect")
if (missing(col.connect)) col.connect <- iGetopt("col.connect")
if (missing(lwd.connect)) lwd.connect <- iGetopt("lwd.connect")
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(showScaleBarLength)) showScaleBarLength <- iGetopt("showScaleBarLength")
if (missing(cex.scaleBar)) cex.scaleBar <- iGetopt("cex.scaleBar")
if (missing(showAnnuliLabels)) showAnnuliLabels <- iGetopt("showAnnuliLabels")
if (missing(annuliLabels)) annuliLabels <- iGetopt("annuliLabels")
if (!showAnnuliLabels) if (!is.null(annuliLabels))
STOP("'annuliLabels' not needed when 'showAnnuliLabels=FALSE'")
if (missing(col.ann)) col.ann <- iGetopt("col.ann")
if (missing(cex.ann)) cex.ann <- iGetopt("cex.ann")
if (missing(offset.ann)) {
# if using arrows and user did not set value then use slightly larger
# offset.ann because arrows are larger relative to other pch.shows
if (!useArrows) offset.ann <- iGetopt("offset.ann")
else offset.ann <- 0.8
}
dat <- NULL # try to avoid "no visible binding" note
## Get image file names ######################################################
## If nms is missing then allow the user to choose a file or files
if (missing(nms)) nms <- iHndlFilenames(nms,filter="RData",multi=TRUE) # nocov start
## If nms is an RFishBC object (and not a filename) then extract the
## filename otherwise process the filename(s)
if (inherits(nms,"RFishBC")) nms <- nms$datanm # nocov end
else nms <- iHndlFilenames(nms,filter="RData",multi=TRUE)
## Get number of readings ####################################################
num2do <- length(nms)
## Show the reading(s) ... handle one and multiple readings differently ######
if (num2do==1) {
### Make sure file is an RData file from digitizeRadii()
if (!isRData(nms))
STOP(nms," is not an RData file saved from 'digitizeRadii().")
dat <- readRDS(nms)
if (!inherits(dat,"RFishBC"))
STOP(nms," does not appear to be from 'digitizeRadii().")
img <- iShowOneDigitizedImage(dat,deviceType,
showScaleBarLength,col.scaleBar,
lwd.scaleBar,cex.scaleBar,
connect,col.connect,lwd.connect,
useArrows,pch.show,col.show,cex.show,
showAnnuliLabels,annuliLabels,
col.ann,cex.ann,offset.ann)
} else {
tmp <- NULL
for (i in seq_along(nms)) {
### Make sure each file is an RData file from digitizeRadii()
if (!isRData(nms[i]))
STOP(nms[i]," is not an RData file saved from 'digitizeRadii().")
dat <- readRDS(nms[i])
if (!inherits(dat,"RFishBC"))
STOP(nms[i]," does not appear to be from 'digitizeRadii().")
if (!is.null(tmp)) {
if (dat$image!=tmp) {
grDevices::dev.off()
STOP("Files appear to derive from different structure images.")
}
}
tmp <- dat$image
### expand pchs, colors, cexs, lwds to number of readings/transects
pch.show <- rep(pch.show,ceiling(num2do/length(pch.show)))
col.show <- rep(col.show,ceiling(num2do/length(col.show)))
cex.show <- rep(cex.show,ceiling(num2do/length(cex.show)))
col.connect <- rep(col.connect,ceiling(num2do/length(col.connect)))
lwd.connect <- rep(lwd.connect,ceiling(num2do/length(lwd.connect)))
### Make or add to image
if (i==1)
img <- iShowOneDigitizedImage(dat,deviceType,
showScaleBarLength,col.scaleBar,
lwd.scaleBar,cex.scaleBar,
connect,col.connect[i],lwd.connect[i],
useArrows,pch.show[i],col.show[i],cex.show[i],
showAnnuliLabels=FALSE,annuliLabels="",
col.ann[i],cex.ann[i],offset.ann[i])
else { # nocov start
## Show connected points if asked to do so
if (connect) graphics::lines(y~x,data=dat$pts,
lwd=lwd.connect[i],col=col.connect[i],
ljoin=1)
## Show points (only show points that were considered annuli)
if (useArrows) {
pos <- iFindLabelPos(dat)
lbl <- intToUtf8(c(9650,9658,9660,9668)[pos])
graphics::text(y~x,data=dat$pts[2:(nrow(dat$pts)-1),],labels=lbl,
col=col.show[i],cex=cex.show[i],pos=pos,offset=0)
if (dat$edgeIsAnnulus)
graphics::text(y~x,data=dat$pts[nrow(dat$pts),],labels=lbl,
col=col.show[i],cex=cex.show[i],
pos=pos,offset=0)
} else {
graphics::points(dat$pts[2:(nrow(dat$pts)-1),],
pch=pch.show[i],col=col.show[i],cex=cex.show[i])
if (dat$edgeIsAnnulus)
graphics::points(dat$pts[nrow(dat$pts),],
pch=pch.show[i],col=col.show[i],cex=cex.show[i])
}
} # nocov end
}
}
invisible(img)
}
########################################################################
## Show the first digitized image.
########################################################################
iShowOneDigitizedImage <- function(dat,deviceType,
showScaleBarLength,col.scaleBar,
lwd.scaleBar,cex.scaleBar,
connect,col.connect,lwd.connect,
useArrows,pch.show,col.show,cex.show,
showAnnuliLabels,annuliLabels,
col.ann,cex.ann,offset.ann) {
## Get and display the image
img <- iGetImage(dat$image,id=NULL,
windowSize=dat$windowSize,deviceType=deviceType,
showInfo=FALSE,pos.info=NULL,cex.info=NULL,col.info=NULL)
## Show scale-bar, if it was digitized, and scale-bar length if asked for
if (!is.null(dat$sbPts)) {
graphics::lines(y~x,data=dat$sbPts,col=col.scaleBar,lwd=lwd.scaleBar)
if (showScaleBarLength) iShowScaleBarLength(dat,col.scaleBar,cex.scaleBar)
}
## Connected points with a line if asked to do so
if (connect) graphics::lines(y~x,data=dat$pts,
col=col.connect,lwd=lwd.connect,ljoin=1)
## Show points (only show points that were considered annuli)
num.ann <- ifelse(dat$edgeIsAnnulus,nrow(dat$pts)-1,nrow(dat$pts)-2)
if (length(col.show)>1 & length(col.show)<num.ann)
WARN("'col.show' was recycled")
if (length(cex.show)>1 & length(cex.show)<num.ann)
WARN("'cex.show' was recycled")
if (useArrows) {
pos <- iFindLabelPos(dat)
lbl <- intToUtf8(c(9650,9658,9660,9668)[pos])
lbl <- Encoding(lbl)
graphics::text(y~x,data=dat$pts[2:(nrow(dat$pts)-1),],labels=lbl,
col=col.show,cex=cex.show,pos=pos,offset=0)
if (dat$edgeIsAnnulus)
graphics::text(y~x,data=dat$pts[nrow(dat$pts),],labels=lbl,
col=col.show[length(col.show)],cex=cex.show[length(cex.show)],
pos=pos,offset=0)
} else {
if (length(pch.show)>1 & length(pch.show)<num.ann)
WARN("'pch.show' was recycled")
graphics::points(dat$pts[2:(nrow(dat$pts)-1),],pch=pch.show,col=col.show,cex=cex.show)
if (dat$edgeIsAnnulus)
graphics::points(dat$pts[nrow(dat$pts),],pch=pch.show[length(pch.show)],
col=col.show[length(col.show)],cex=cex.show[length(cex.show)])
}
#### Show annuli labels if asked to do so
if (showAnnuliLabels)
iShowAnnuliLabels(dat,annuliLabels=annuliLabels,
col.ann=col.ann,cex.ann=cex.ann,offset.ann=offset.ann)
invisible(img)
}
########################################################################
## Show annuli numbers on the showDigitizedImage() image
########################################################################
iShowAnnuliLabels <- function(dat,annuliLabels,
col.ann,cex.ann,offset.ann) { # nocov start
## Get points to plot
pts <- dat$pts
## Finda annuli list
#### Use all annuli if annuliLabels not supplied by user
if (is.null(annuliLabels)) annuliLabels <- 1:max(dat$radii$agecap)
#### Make sure provided annuliLabels exist in the data
annuliLabels <- annuliLabels[annuliLabels %in% rownames(pts)]
#### Get just the points to be labelled
pts <- pts[rownames(pts) %in% annuliLabels,]
## Check colors and cexs
if (length(col.ann)>1 & length(col.ann)<length(annuliLabels))
WARN("'col.ann' was recycled.")
if (length(cex.ann)>1 & length(cex.ann)<length(annuliLabels))
WARN("'cex.ann' was recycled.")
## Find a position relative to the point for the text based on transect slope
pos <- iFindLabelPos(dat)
## put the labels on the plot
graphics::text(y~x,data=pts,labels=annuliLabels,font=2,
col=col.ann,cex=cex.ann,pos=pos,offset=offset.ann)
} # nocov end
########################################################################
## Find a position for the "arrow" or the annulus label based on the
## slope of the transect or the first and last selected points.
########################################################################
iFindLabelPos <- function(dat) {
## Get slope of transect if used, otherwise find rough value from 1st/ last pts
if (!is.null(dat$slpTransect)) slp <- dat$slpTransect
else {
tmp <- dat$pts[c(1,nrow(dat$pts)),]
slp <- diff(tmp$y)/diff(tmp$x)
}
## Convert slope to degrees
deg <- atan(slp)*180/pi
## Adjust for the quadrant in which the transect is in
if (dat$pts$x[nrow(dat$pts)]<dat$pts$x[1]) deg <- deg+180
## Convert absolute transect degrees into a position for the text/arrow
deg <- abs(deg)
if (deg>=0 & deg<=45) pos <- 1L # below
else if (deg>45 & deg<=90) pos <- 4L # right
else if (deg>90 & deg<=135) pos <- 2L # left
else if (deg>135 & deg<=180) pos <- 1L # below
else if (deg>180 & deg<=225) pos <- 1L # below
else if (deg>225 & deg<=270) pos <- 4L # right
else if (deg>270 & deg<=315) pos <- 2L # left
else if (deg>315 & deg<=360) pos <- 1L # below
## Return the position
pos
}
########################################################################
## Show known length of scale-bar on the showDigitizedImage() image
########################################################################
iShowScaleBarLength <- function(dat,col.scaleBar,cex.scaleBar) { # nocov start
## Get the scale-bar points, length, and units
pts <- dat$sbPts
len <- dat$sbLength
if (!"sbUnits" %in% names(dat)) {
### Allows use with data created before sbUnits was added (v0.2.1)
units <- "units"
} else {
### Handles after sbUnits was added
units <- ifelse(is.null(dat$sbUnits),"units",dat$sbUnits)
}
### Change "units" to "unit" if the scale-bar length is 1
if (units=="units" & isTRUE(all.equal(len,1))) units <- "unit"
## Find the degree of angle for the scale-bar slope
deg <- atan(diff(pts$y)/diff(pts$x))*180/pi
## Convert absolute transect degrees into a position for the text
pos <- ifelse(deg>=0 & deg<=45,1,4)
## Create a label
lbl <- paste(len,units,sep=" ")
## Place text at the midpoint of the transect
graphics::text(mean(pts$x),mean(pts$y),label=lbl,pos=pos,
col=col.scaleBar,cex=cex.scaleBar)
} # nocov end
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.