Nothing
#' Make QR codes
#'
#' A helper function for QR code generation using the 'qrencoder' library for faster QR code generation.
#' It converts the generated QR code into a raster grob image that can
#' be plotted using the `grid.draw()` function in the 'grid' package.
#'
#' @param my_id Unique ID string to be encoded to QR code.
#' @param ec_level The error correction level (`0` - `3`, lowest to highest).
#'
#' @returns A QR code as a raster grob image object that can be plotted with the `grid.draw()`
#' function in the 'grid' package.
#'
#' @examplesIf rlang::is_installed(c("raster", "qrencoder", "assertthat", "grid"))
#' library(qrlabelr)
#' qr <- make_qrcode("KUMASI2023_PYT_101_1_1", ec_level = 1)
#'
#' # Plot QR code using the grid package
#' grid::pushViewport(grid::viewport(x = grid::unit(0.5, "npc"),
#' y = grid::unit(0.5, "npc"),
#' width = grid::unit(1, "in"),
#' height = grid::unit(1, "in")))
#' grid::grid.draw(qr)
#' # clean up any open graphical device
#' # grDevices::graphics.off()
#'
#' @export
make_qrcode <- function(my_id, ec_level = 3){
assertthat::assert_that(!missing(my_id),
msg = "Please provide a unique ID.")
assertthat::assert_that(ec_level >= 0 && ec_level <= 3, msg = "Please provide an error
correction level value in the range 0 - 3.")
# Create qrcode and store as a rasterGrob image
aa <- raster::raster(qrencoder::qrencode_raw(as.character(my_id), ec_level))
qr <- grid::rasterGrob(raster::as.raster(aa, col = c('white','black')),
interpolate = FALSE)
return(qr)
} # end of make_qrcode function
#' Create custom machine- and human-readable rectangular plot labels
#'
#' @description
#' Create print-ready customized plot labels affixed with QR codes given the page setup,
#' label dimensions, the number of rows and columns of labels to print per page.
#'
#' @returns A PDF file containing experimental plot labels affixed with QR codes, saved to the default or working directory.
#'
#' @param wdt The label width in inches.
#' @param hgt The label height in inches.
#' @param page_wdt The page width in inches.
#' @param page_hgt The page height in inches.
#' @param top_mar The page top margin in inches.
#' @param bot_mar The page bottom margin in inches.
#' @param left_mar The page left margin in inches.
#' @param right_mar The page right margin in inches.
#' @param numrow The number of label rows per page. It should be an integer.
#' @param numcol The number of label columns per page. It should be an integer.
#' @param filename A character prefix or path for the pdf file to be created. Default path
#' is working directory.
#' @param font_sz The font size to use.
#' @param Treetag Set to TRUE if creating a treetag label.
#' @param family The font style to use to print labels.
#' @param rounded Set to TRUE if label has round corners; set to false if label has
#' square corners.
#' @param print_across Set to TRUE to print labels across rows, left to right; else
#' set to FALSE to print labels down columns, top to bottom. Default is \code{TRUE}.
#' @param rect Set to TRUE to draw rectangles around labels, else set to FALSE.
#' Default is \code{TRUE}.
#' @param top_left_1 String for top-left row 1 position on a rectangular label.
#' @param top_left_2 String for top-left row 2 position on a rectangular label.
#' @param top_right_1 String for top-right row 1 position on a rectangular label.
#' @param top_right_2 String for top-right row 2 position on a rectangular label.
#' @param center_right_1 String for center-right row 1 position on a rectangular label.
#' @param center_right_2 String for center-right row 2 position on a rectangular label.
#' @param center_right_3 String for center-right row 3 position on a rectangular label.
#' @param bottom_left_1 String for bottom-left row 1 position on a rectangular label.
#' @param bottom_left_2 String for bottom-left row 2 position on a rectangular label.
#' @param unique_id A vector containing unique identifiers or strings to generate QR codes.
#' @param ec_level The error correction level (`0` - `3`, lowest to highest) for QR codes.
#' @param ... Additional optional arguments to be supplied.
#'
#' @seealso \code{\link{field_label}} and \code{\link{gp_label}}
#'
#' @examples
#' library(qrlabelr)
#' file <- tempfile()
#' \donttest{
#' if(file.exists(file))
#' # Create rectangular plot labels based on the Avery 94220 template-- the default template
#' create_label(
#' font_sz = 10,
#' filename = file,
#' print_across = TRUE,
#' rect = TRUE,
#' top_left_1 = paste("Plot:", 101:105),
#' top_left_2 = paste("Row:", c(rep(1, 3), rep(2, 2))),
#' top_right_1 = paste("Rep:", rep(1, 5)),
#' top_right_2 = paste("Col:", c(1:3, 1:2)),
#' center_right_1 = paste("iBLOCK:", c(rep(1, 3), rep(2, 2))),
#' center_right_2 = paste("Seed:", rep("OFF_NUR", 5)),
#' center_right_3 = rep("AWk", 5),
#' bottom_left_1 = paste("Loc:", rep("BAMBEY", 5)),
#' bottom_left_2 = paste0("G-", 1:5),
#' unique_id = paste("KUMASI2023_PYT", c(101:105),
#' c(rep(1, 3), rep(2, 2)), c(1:3, 1:2),
#' sep = "_"),
#' ec_level = 1)
#' }
#'
#'
#'
#' @export
create_label <- function(
wdt = 2, # label width
hgt = 1, # Label height
page_wdt = 8.5, # page width
page_hgt = 11, # page height
top_mar = 0.625, # top margin
bot_mar = 0.625, # bottom margin
left_mar = 0.625, # left margin
right_mar = 0.625, # right margin
numrow = 8L, # number of label rows per page
numcol = 3L, # number of label columns per page
filename = 'PlotLabel', # name for pdf file to be created
font_sz = 8,
Treetag = FALSE,
family = 'sans', # Font style to use
rounded = TRUE, # Rounded corners
print_across = TRUE,
rect = TRUE,
top_left_1 = NULL, # Text for top-left row 1
top_left_2 = NULL, # Text for top-left row 2
top_right_1 = NULL, # Text for top-right row 1
top_right_2 = NULL, # Text for top-right row 2
center_right_1 = NULL, # Text for center-right row 1
center_right_2 = NULL, # Text for center-right row 2
center_right_3 = NULL, # Text for center-right row 3
bottom_left_1 = NULL, # Text for bottom-left row 1
bottom_left_2 = NULL, # Text for bottom-left row 2
unique_id = NULL, # Unique ids for QR codes
ec_level = 3,
...){
error_numeric <- "must be a positive numeric value."
error_flag <- "must be a logical or boolean value."
error_string <- "must be string value."
# Function to check for positive values -- may have to be relocated
is.valid_number <- function (x) {
if (x >= 0 && assertthat::is.number(x)) return (TRUE) else return (FALSE)
}
# Used in assertions to check if number is an integer and positive
is.valid_count <- function (x) {
if (x > 0 && assertthat::is.count(x)) return (TRUE) else return (FALSE)
}
## Assertions start --
# Checking all numeric inputs
assertthat::assert_that(is.valid_number(wdt),
msg = paste("'wdt'", error_numeric))
assertthat::assert_that(is.valid_number(hgt),
msg = paste("'hgt'", error_numeric))
assertthat::assert_that(is.valid_number(page_wdt),
msg = paste("'page_wdt'", error_numeric))
assertthat::assert_that(is.valid_number(page_hgt),
msg = paste("'page_hgt'", error_numeric))
assertthat::assert_that(is.valid_number(top_mar),
msg = paste("'top_mar'", error_numeric))
assertthat::assert_that(is.valid_number(bot_mar),
msg = paste("'bot_mar'", error_numeric))
assertthat::assert_that(is.valid_number(left_mar),
msg = paste("'left_mar'", error_numeric))
assertthat::assert_that(is.valid_number(right_mar),
msg = paste("'right_mar'", error_numeric))
assertthat::assert_that(is.valid_count(numrow),
msg = paste("'numrow'", "must be a positive integer."))
assertthat::assert_that(is.valid_count(numcol),
msg = paste("'numcol'", "must be a positive integer."))
assertthat::assert_that(is.valid_number(font_sz),
msg = paste("'font_sz'", error_numeric))
# Checking all flag inputs
assertthat::assert_that(assertthat::is.flag(Treetag),
msg = paste("'Treetag'", error_flag))
assertthat::assert_that(assertthat::is.flag(rounded),
msg = paste("'rounded'", error_flag))
# Checking all string inputs
assertthat::assert_that(assertthat::is.string(filename),
msg = paste("'filename'", error_string))
assertthat::assert_that(assertthat::is.string(family),
msg = paste("'family'", error_string))
# assertthat::assert_that(assertthat::is.string(top_left_1),
# msg = paste("'top_left_1'", error_string))
#
# assertthat::assert_that(assertthat::is.string(top_left_2),
# msg = paste("'top_left_2'", error_string))
#
# assertthat::assert_that(assertthat::is.string(top_right_1),
# msg = paste("'top_right_1'", error_string))
#
# assertthat::assert_that(assertthat::is.string(top_right_2),
# msg = paste("'top_right_2'", error_string))
#
# assertthat::assert_that(assertthat::is.string(center_right_1),
# msg = paste("'center_right_1'", error_string))
#
# assertthat::assert_that(assertthat::is.string(center_right_2),
# msg = paste("'center_right_2'", error_string))
#
# assertthat::assert_that(assertthat::is.string(center_right_3),
# msg = paste("'center_right_3'", error_string))
#
# assertthat::assert_that(assertthat::is.string(bottom_left_1),
# msg = paste("'bottom_left_1'", error_string))
#
# assertthat::assert_that(assertthat::is.string(bottom_left_2),
# msg = paste("'bottom_left_2'", error_string))
## -- Assertions end
# Calculate space between label columns if any
if (numcol == 1) {
col_space <- 0
} else {
col_space <- (page_wdt - left_mar - right_mar - numcol*wdt)/(numcol-1)
}
# Calculate space between label rows if any
if (numrow == 1) {
row_space <- 0
} else {
row_space <- (page_hgt - top_mar - bot_mar - numrow*hgt)/(numrow-1)
}
# Check if page setup matches label setup per page.
# Error message if either column spaces or the row spaces between labels
# are less than zero
if (col_space < 0 | row_space < 0) {
stop("Page setup does not match label setup per page.")
}
# clean up any open graphical devices if function fails
on.exit(grDevices::graphics.off())
# Create text for top-left row 1 -- plot id
if (!is.null(top_left_1)) {
plotid <- top_left_1
} else {
plotid <- NULL
}
# Create text for top-left row 2 -- row id
if (!is.null(top_left_2)) {
rowid <- top_left_2
} else {
rowid <- NULL
}
# Create text for top-right row 1 -- rep id
if (!is.null(top_right_1)) {
repid <- top_right_1
} else {
repid <- NULL
}
# Create text for top-right row 2 -- col id
if (!is.null(top_right_2)) {
colid <- top_right_2
} else {
colid <- NULL
}
# Create text for center-right row 1 -- iblock id
if (!is.null(center_right_1)) {
blkid <- center_right_1
} else {
blkid <- NULL
}
# Create text for center-right row 2 -- seed source id
if (!is.null(center_right_2)) {
sds <- center_right_2
} else {
sds <- NULL
}
# Create text for center-right row 3 -- researcher's name id
if (!is.null(center_right_3)) {
rname <- center_right_3
} else {
rname <- NULL
}
# Create text for bottom-left row 1 -- loc id
if (!is.null(bottom_left_1)) {
loc1 <- bottom_left_1
} else {
loc1 <- NULL
}
# Create text for bottom-left row 2 -- loc id
if (!is.null(bottom_left_2)) {
entry <- bottom_left_2
} else {
entry <- NULL
}
# Create QR codes from unique ids
if (!is.null(unique_id)) {
bb <- unique_id |> purrr::map(\(x) make_qrcode(ec_level = ec_level, x))
nn <- length(bb) # total number of labels to generate
} else {
stop("Unique IDs for generating QR codes are missing!!")
}
# Generate label positions -- prints across rows of grid layout
if (print_across == TRUE) {
pos <- expand.grid(x = 1:numcol, y = 1:numrow)
} else {
pos <- expand.grid(y = 1:numrow, x = 1:numcol)
}
duplication <- ceiling(nn/nrow(pos))
label_pos <- do.call("rbind", replicate(duplication, pos, simplify = FALSE))
corx <- label_pos$x # label x coordinate
cory <- label_pos$y # label y coordinate
# Create pdf file to be saved in working directory
filename <- paste0(filename, paste0(wdt,'in'), 'x',
paste0(hgt,'in'), Sys.time()) # name of pdf file
filename <- paste0(gsub(":","_", filename), ".pdf")
# Font size to print text on labels
fsize <- font_sz
# Define new coordinates for QR code
wdt1 <- 0.5 * wdt
hgt1 <- 0.5 * hgt
qry <- hgt1/1.2
# Create pdf file
# The argument family specifies the initial/default font family to be
# used. Device independent fonts that can be used include 'sans', 'serif' and
# 'mono', default is sans.
grDevices::pdf(filename,
width = page_wdt,
height = page_hgt,
onefile = TRUE,
family = family) # Letter size paper from Avery
# Grid layout for labels
label_layout <- grid::grid.layout(numrow, numcol,
widths = grid::unit(c(rep(wdt + col_space, numcol-1), wdt), "in"),
heights = grid::unit(c(rep(hgt + row_space, numrow-1), hgt), "in"))
if (Treetag == TRUE) {
# Viewport for first QR codes
qq <- grid::viewport(x = grid::unit(0.57, "npc"),
y = grid::unit(0.3, "npc"),
angle = 90,
width = grid::unit(wdt1, "in"),
height = grid::unit(qry, "in"),
just = c('right','center'))
# Viewport for IBlock
bl <- grid::viewport(x = grid::unit(0.1, "npc"),
y = grid::unit(0.3, "npc"),
angle = 90,
width = grid::unit(0.55*wdt, "in"),
height = grid::unit(0.8*hgt1, "in"),
just = "left")
# Viewport for second QR code
qq2 <- grid::viewport(x = grid::unit(0.5, "npc"),
y = grid::unit(0.9, "npc"),
width = grid::unit(wdt1, "inches"),
height = grid::unit(qry, "inches"),
just = c('center'))
px <- 0.11*wdt # x coordinate for plot
py <- 0.05*hgt # y coordinate for plot
rx <- 0.27*wdt # x coordinate for row
ry <- 0.4*hgt # y coordinate for Rep
lx <- 0.9*wdt # x coordinate for location
ly <- 0.4*hgt # y coordinate for location
ex <- 0.9*wdt # x coordinate for first entry
ee <- 0.85*wdt # x coordinate for second entry
ey <- 0.83*hgt # y coordinate for second entry
nx <- 0.6*wdt # x coordinate for researcher's name
} else {
# Create a viewport for each label
aa <- grid::viewport(x = grid::unit(0, "npc"),
y = grid::unit(1, "npc"),
width = grid::unit(wdt, "in"),
height = grid::unit(hgt, "in"),
just = c('left','top'))
# Define viewport for QR code; note coordinates and dimension
qq <- grid::viewport(x = grid::unit(0.5, "npc"),
width = grid::unit(wdt1, "in"),
height = grid::unit(qry, "in"),
just = c('right','center'))
# Define viewport for Block ID if it is an incomplete block design
bl <- grid::viewport(x = grid::unit(0.47, "npc"),
width = grid::unit(0.55*wdt, "in"),
height = grid::unit(0.8*hgt1, "in"),
just = "left")
# Coordinates for adding text labels to grids
px <- 0.1*wdt # x coordinate for plot
py <- 0.92*hgt # y coordinate for plot
rx <- 0.6*wdt # x coordinate for rep
ry <- 0.78*hgt # y coordinate for row
ly <- 0.22*hgt # y coordinate for location
ex <- 0.05*wdt # x coordinate for entry
ey <- 0.1*hgt # y coordinate for entry
}
# Viewport for a new page
new.page <- grid::viewport(width = grid::unit(page_wdt, "in"),
height = grid::unit(page_hgt, "in"))
# Create a viewport for each page using grid layout
lab_vp <- grid::viewport(layout = label_layout)
grid::pushViewport(lab_vp)
bold_font <- grid::gpar(fontface = "bold", fontsize = fsize)
bold_font2 <- grid::gpar(fontface = "bold", fontsize = fsize-2)
plain_font2 <- grid::gpar(fontface = "plain", fontsize = fsize-2)
plain_font3 <- grid::gpar(fontface = "plain", fontsize = fsize-4)
bold_font3 <- grid::gpar(fontface = "bold", fontsize = fsize-4)
plain_font4 <- grid::gpar(fontface = "plain", fontsize = floor(fsize/2.5))
# Define progres bar parameters
pro_bar <- txtProgressBar(min = 0, max = nn, style = 3, char = '=')
for (i in seq_len(nn)) {
# set progress bar to chromosome indexing
setTxtProgressBar(pro_bar, value = i)
label_posn <- c(x = corx[i], y = cory[i])
if (all(i != 1 & label_posn == c(1, 1))) {
grid::grid.newpage()
grid::pushViewport(new.page)
grid::pushViewport(lab_vp)
}
if (Treetag == TRUE) {
tt <- grid::viewport(layout.pos.row=label_posn['y'],
layout.pos.col=label_posn['x'])
grid::pushViewport(tt)
# Draw rectangle around labels
if (rect == TRUE) {
if (rounded == TRUE) {
grid::grid.roundrect(gp = grid::gpar(lwd = 0.5))
} else (grid::grid.rect(gp = grid::gpar(lwd = 0.5)))
}
# Add Plot ID to label; note coordinates
grid::grid.text(label = plotid[i],
x = grid::unit(px, "in"),
y = grid::unit(py, "in"), rot = 90,
gp = bold_font, hjust = 0, vp = tt)
# Add Rep ID to label; note coordinates
grid::grid.text(label = repid[i],
x = grid::unit(px, "in"),
y = grid::unit(ry, "in"), rot = 90,
gp = bold_font, hjust = 0, vp = tt)
# Add Row ID to label; note coordinates
grid::grid.text(label = rowid[i],
x = grid::unit(rx, "in"),
y = grid::unit(py, "in"), rot = 90,
gp = bold_font2, hjust = 0, vp = tt)
# Add column ID to label; note coordinates
grid::grid.text(label = colid[i],
x = grid::unit(rx, "in"),
y = grid::unit(ry, "in"), rot = 90,
gp = bold_font2, hjust = 0, vp = tt)
# Define viewport for QR code; note coordinates and dimension
grid::pushViewport(qq)
# Add first QR code
grid::grid.draw(bb[[i]])
grid::popViewport()
# Define viewport for Block ID if it is an incomplete block design
grid::pushViewport(bl)
# Add Block ID to label; note coordinates
grid::grid.text(label = blkid[i],
x = grid::unit(0.2, "npc"),
y = grid::unit(0.35, "npc"),
rot = 360, gp = plain_font2, hjust = 0)
# Go back to label viewport
grid::upViewport()
# Add location of experiment to label
grid::grid.text(label = loc1[i], rot = 90,
x = grid::unit(lx, "in"),
y = grid::unit(ly, "in"),
gp = plain_font4, hjust = 0, vp = tt)
# Add seed source to label; note coordinates
grid::grid.text(label = sds[i],
x = grid::unit(0.6, "npc"),
y = grid::unit(0.35, "npc"),
rot = 90, vp = tt,
gp = plain_font3, hjust = 0, )
# Add researcher's name to label; note coordinates
grid::grid.text(label = rname,
x = grid::unit(0.72, "npc"),
y = grid::unit(0.35, "npc"),
rot = 90, vp = tt,
gp = plain_font3, hjust = 0, )
# Add entry or treatment name to label
grid::grid.text(label = entry[i], rot = 90,
x = grid::unit(ex, "in"),
y = grid::unit(py, "in"),
gp = bold_font3, hjust = 0, vp = tt)
# Add entry or treatment name to label tear-off
grid::grid.text(label = entry[i], rot = 90,
x = grid::unit(ee, "in"),
y = grid::unit(ey, "in"),
gp = plain_font4, hjust = 0, vp = tt)
grid::pushViewport(qq2)
# Add second QR code
grid::grid.draw(bb[[i]])
grid::popViewport(2)
} else {
grid::pushViewport(grid::viewport(layout.pos.row=label_posn['y'],
layout.pos.col=label_posn['x']))
grid::pushViewport(aa)
# Draw rectangle around labels
if (rect == TRUE) {
if (rounded == TRUE) {
grid::grid.roundrect(gp = grid::gpar(lwd = 0.5))
} else (grid::grid.rect(gp = grid::gpar(lwd = 0.5)))
}
# Add Plot ID to label; note coordinates
grid::grid.text(label = plotid[i],
x = grid::unit(px, "in"),
y = grid::unit(py, "in"),
gp = bold_font, hjust = 0, vp = aa)
# Add Rep ID to label; note coordinates
grid::grid.text(label = repid[i],
x = grid::unit(rx, "in"),
y = grid::unit(py, "in"),
gp = bold_font, hjust = 0, vp = aa)
# Add Row ID to label; note coordinates
grid::grid.text(label = rowid[i],
x = grid::unit(px, "in"),
y = grid::unit(ry, "in"),
gp = bold_font2, hjust = 0, vp = aa)
# Add column ID to label; note coordinates
grid::grid.text(label = colid[i],
x = grid::unit(rx, "in"),
y = grid::unit(ry, "in"),
gp = bold_font2, hjust = 0, vp = aa)
# Add seed source to label; note coordinates
grid::grid.text(label = sds[i],
x = grid::unit(0.42, "npc"),
y = grid::unit(0.47, "npc"),
gp = plain_font3, hjust = 0, vp = aa)
# Add researcher's name to label; note coordinates
grid::grid.text(label = rname,
x = grid::unit(0.42, "npc"),
y = grid::unit(0.35, "npc"),
gp = plain_font3, hjust = 0, vp = aa)
# Push viewport for qr code
grid::pushViewport(qq)
# Add QR code
grid::grid.draw(bb[[i]])
grid::popViewport()
# Define viewport for Block ID if it is an incomplete block design
grid::pushViewport(bl)
# Add Block ID to label; note coordinates
# Add Block ID to label; note coordinates
grid::grid.text(label = blkid[i],
x = grid::unit(0.01, "npc"),
y = grid::unit(0.8, "npc"),
gp = plain_font3, hjust = 0)
# Go back to label viewport
grid::upViewport()
# Add location of experiment to label
grid::grid.text(label = loc1[i],
x= grid::unit(px, "in"),
y = grid::unit(ly, "in"),
gp = plain_font4, hjust = 0, vp = aa)
# Add entry or treatment name to label
grid::grid.text(label = entry[i],
x= grid::unit(ex, "in"),
y = grid::unit(ey, "in"),
gp = bold_font3, hjust = 0, vp = aa)
grid::popViewport(2)
}
}
} # End of create_label ()
#' Create field plot labels embossed with QR codes
#' @description
#' Create machine- and human-readable plot labels that are well-suited for field experiments.
#'
#' @returns A PDF file containing field plot labels affixed with QR codes, and a
#' data frame of an updated field book; all saved to the default or working directory.
#'
#' @param dat An input data frame of field book that contains plot attributes.
#' To design field plot labels, the imported field book must have LOCATION, PLOT,
#' ROW, COLUMN/RANGE, REP, TREATMENT columns. The order of the columns in the field book
#' is not important, and the columns can be any name the user desires.
#' @param get_unique_id Set to 'ruid' if reproducible and informative unique ids
#' are to be generated from imported field book. Set to 'uuid' if universal unique ids
#' are to be generated from imported field book. Set to 'custom' if imported field book
#' already has unique IDs for each plot.
#' @param unique_id The column identifier for UNIQUE_ID in the imported field book.
#' @param filename A character prefix or path for the pdf file to be created. Default path
#' is working directory.
#' @param Year The year of experiment or trial.
#' @param rname The researcher's name. Initials or initials of first and middle
#' names and the last name.
#' @param Trial The name of the trial to use.
#' @param seed_source Set to TRUE if seed source is included in the imported field book,
#' FALSE if otherwise.
#' @param IBlock Set to TRUE if \code{dat} contains incomplete blocks within replications.
#' @param rep_id The column identifier for REP in the imported field book.
#' @param plot_id The column identifier for PLOT in the imported field book.
#' @param row_id The column identifier for ROW in the imported field book.
#' @param col_id The column identifier for COLUMN in the imported field book.
#' @param loc_id The column identifier for LOCATION in the imported field book.
#' @param entry_id The column identifier for ENTRY/TREATMENT in the imported field book.
#' @param IBlock_id The column identifier for IBLOCK in the imported field book.
#' It must be provided if \code{IBlock} is set to TRUE.
#' @param seed_source_id The column identifier for SEED_SOURCE in the imported field book.
#' It must be provided if \code{seed_source} is set to TRUE.
#' @param ... Additional arguments passed to the \code{create_label()} function.
#'
#' @details
#' The default column identifiers for LOCATION, PLOT, ROW, COLUMN/RANGE, REP, TREATMENT
#' are based on the column IDs of a field book generated using the 'FielDHub' package.
#' If user imports any field book generated with other programs,
#' the user must specify the equivalent column identifiers used for LOCATION, PLOT, REP,
#' ROW, COLUMN, and TREATMENT/ENTRY in the imported field book.
#'
#' if \code{get_unique_id = 'ruid'} (i.e. Reproducible Unique IDs), the function concatenates
#' location, year, trial name, plot, row and column IDs. if \code{get_unique_id = 'uuid'}
#' (i.e. Universal Unique IDs), the function generates UUIDs by time randomly.
#' Note that UUIDs are uninformative and not reproducible.
#'
#' If input field book already has unique IDs for each plot, the \code{get_unique_id}
#' argument should be set to 'custom'; and the \code{unique_id}
#' argument must be specified as a string using the column name in the input field book
#' that denotes plot unique IDs.
#'
#' if \code{Year} is NULL, the function uses the current year as defined in the `sys.time()`.
#'
#' If the user is printing labels for any incomplete block design, the imported
#' field book must include an IBLOCK column if the users wishes to display intra-blocking
#' information for experimental plots on the label.
#'
#' Set the \code{IBlock} argument to TRUE if the field layout has incomplete
#' blocks within replications. The imported field book must include an IBLOCK column if
#' the \code{IBlock} argument is set to TRUE.
#'
#' @seealso \code{\link{create_label}} and \code{\link{gp_label}}
#'
#' @examples
#'
#' library(qrlabelr)
#' df <- data.frame(LOCATION = rep("BAMBEY", 5),
#' PLOT = 1001:1005,
#' ROW = c(rep(1, 3), rep(2, 2)),
#' COLUMN = c(1:3, 1:2),
#' REP = rep(1, 5),
#' IBLOCK = c(rep(1, 3), rep(2, 2)),
#' TREATMENT = paste0("G-", 1:5),
#' SEED_SOURCE = rep("OFF_NUR", 5))
#' df$ids <- paste0(df$LOCATION,'2023', '_PYT', '_', df$PLOT, '_', df$ROW, '_',
#' df$COLUMN)
#' file <- tempfile()
#' \donttest{
#' if(file.exists(file))
#' field_label(
#' dat = df,
#' wdt = 5,
#' hgt = 2,
#' page_wdt = 8.5,
#' page_hgt = 11,
#' top_mar = 0.75,
#' bot_mar = 0.75,
#' left_mar = 1.75,
#' right_mar = 1.75,
#' numrow = 4L,
#' numcol = 1L,
#' filename = file,
#' font_sz = 20,
#' Trial = "PYT",
#' Year = 2023,
#' family = "sans",
#' rounded = TRUE,
#' IBlock = TRUE,
#' get_unique_id = "ruid",
#' rname = "AW Kena",
#' seed_source = TRUE,
#' seed_source_id = "SEED_SOURCE",
#' ec_level = 1)
#' }
#'
#' @export
field_label <- function(dat,
get_unique_id = c("ruid", "uuid", "custom"), # Generate unique ids for QR codes
unique_id = NULL,
filename = "PlotLabel",
Year = NULL,
rname = NULL,
Trial = 'PYT',
seed_source = FALSE,
IBlock = FALSE, # Set to TRUE if it is an incomplete block design
rep_id = 'REP',# Input id for REP
plot_id = 'PLOT', # Input id for PLOT
row_id = 'ROW', # Input id for ROW
col_id = 'COLUMN', # Input for COLUMN
loc_id = 'LOCATION', # Input id for LOCATION
entry_id = 'TREATMENT', # Input id for TREATMENT
IBlock_id = 'IBLOCK', # Input id for IBLOCK
seed_source_id = NULL,
...){
error_numeric <- "must be a positive numeric value."
error_flag <- "must be a logical or boolean value."
error_string <- "must be string value."
# Function to check for positive values -- may have to be relocated
is.valid_number <- function (x) {
if (x >= 0 && assertthat::is.number(x)) return (TRUE) else return (FALSE)
}
# Used in assertions to check if number is an integer and positive
is.valid_count <- function (x) {
if (x > 0 && assertthat::is.count(x)) return (TRUE) else return (FALSE)
}
# Assertion for dat argument
assertthat::assert_that(!missing(dat),
msg = "Fieldbook is missing, please provide a fieldbook as a data frame.")
# Checking all flag inputs
assertthat::assert_that(assertthat::is.flag(seed_source),
msg = paste("'seed_source'", error_flag))
assertthat::assert_that(assertthat::is.flag(IBlock),
msg = paste("'IBlock'", error_flag))
# Checking all string inputs
assertthat::assert_that(get_unique_id %in% c("ruid", "uuid", "custom"),
msg = paste("'get_unique_id' must be a string value",
"of one of these: 'ruid','uuid' or 'custom'"))
if (get_unique_id == "custom" & is.null(unique_id)) {
stop(paste("Use the 'unique_id' argument to specify the column name in your fieldbook containing unique ids."))
}
if (seed_source == TRUE & is.null(seed_source_id)) {
stop(paste("Use the 'seed_source_id' argument to specify the column name in your fieldbook containing seed source ids."))
}
# Checking all flag inputs
assertthat::assert_that(assertthat::is.string(Trial),
msg = paste("'Trial'", error_string))
assertthat::assert_that(assertthat::is.string(rep_id),
msg = paste("'rep_id'", error_string))
assertthat::assert_that(assertthat::is.string(plot_id),
msg = paste("'plot_id'", error_string))
assertthat::assert_that(assertthat::is.string(row_id),
msg = paste("'row_id'", error_string))
assertthat::assert_that(assertthat::is.string(col_id),
msg = paste("'col_id'", error_string))
assertthat::assert_that(assertthat::is.string(loc_id),
msg = paste("'loc_id'", error_string))
assertthat::assert_that(assertthat::is.string(entry_id),
msg = paste("'entry_id'", error_string))
assertthat::assert_that(assertthat::is.string(IBlock_id),
msg = paste("'IBlock_id'", error_string))
# Assert inputs with NULL arguments as default if overwritten by the user
if (!is.null(Year)) {
assertthat::assert_that((assertthat::is.string(Year) || is.valid_number(Year)) && nchar(Year) == 4,
msg = "Year must be a string or numeric value of four characters.")
}
if (!is.null(seed_source_id)) {
assertthat::assert_that(assertthat::is.string(seed_source_id),
msg = "Seed source ID must be a string value.")
}
if (!is.null(rname)) {
assertthat::assert_that(assertthat::is.string(rname),
msg = "Researcher name must be a string value.")
}
# if (!is.null(unique_id)) {
# assertthat::assert_that(assertthat::is.string(unique_id),
# msg = "'unique_id' must be a string value.")
# }
# Define year for experiment
if (is.null(Year) == TRUE) {
yr <- format(Sys.time(),'%Y')
} else {
yr <- as.character(Year)
}
plotid <- paste("Plot ID:", dat[, plot_id]) # Plot ids
repid <- paste("Rep ID:", dat[, rep_id]) # Rep ids
loc1 <- paste("Loc:", dat[, loc_id]) # Location ids
rowid <- paste("Row ID:", dat[, row_id]) # Row ids
colid <- paste("Col. ID:", dat[, col_id]) # Column ids
entry <- dat[, entry_id]
rnames <- rep(rname, nrow(dat)) # Researcher's name
# Block ids if it is an incomplete block design
if (IBlock == TRUE) {
iblock <- dat[, IBlock_id]
blkid <- paste("B:", iblock)
} else {
blkid <- NULL
}
# Show seed source on label
if (seed_source == TRUE) {
sds <- paste(dat[, seed_source_id])
} else {
sds <- NULL
}
# Create unique id: if 'ruid' (i.e. Reproducible Unique IDs), the function concatenates
# loc, year, trial name, plot, row and column. if 'uuid' (i.e. Universal Unique IDs),
# the function generates UUIDs by time randomly. Note that UUIDs are uninformative and not reproducible.
# If 'custom', user must use the 'unique_id' argument to specify the column name
# in field book that denotes custom generated unique IDs.
if (get_unique_id == "ruid"){
trial_name <- gsub(" ", "_", Trial)
loc <- dat[, loc_id]
plott <- dat[, plot_id]
roww <- dat[, row_id]
coll <- dat[, col_id]
UNIQUE_ID <- paste(paste0(gsub(" ", "", loc), yr),
trial_name, plott, roww, coll, sep = "_" )
} else if (get_unique_id == "uuid") {
UNIQUE_ID <- uuid::UUIDgenerate(use.time = TRUE, n = nrow(dat), output = "string")
} else if (get_unique_id == "custom") {
UNIQUE_ID <- dat[, unique_id]
}
# Create an augmented field book containing unique IDs
updat <- dplyr::mutate(dat, UNIQUE_ID)
colnames(updat)[ncol(updat)] <- 'UNIQUE_ID'
if (colnames(updat)[1] == 'ID') {
colnames(updat)[1] <- 'SN'
} else {
colnames(updat)[1] <- colnames(updat)[1]
}
# File name and timestamp for updated fieldbook
ts <- Sys.time() |> format(format = "%H_%M_%S") |>
paste0("Updated_Fieldbook_", ... = _, ".csv")
utils::write.csv(updat, file = paste0(filename, ts), row.names = FALSE)
# Send updated fieldbook from package environment to global environment
#.GlobalEnv$updated_fieldbook <- list(updated_fieldbook = updat)
do.call(create_label, args = list(top_left_1 = plotid,
top_left_2 = rowid,
top_right_1 = repid,
top_right_2 = colid,
center_right_1 = blkid,
center_right_2 = sds,
center_right_3 = rnames,
bottom_left_1 = UNIQUE_ID,
bottom_left_2 = entry,
unique_id = UNIQUE_ID,
filename = filename, ...))
#cat("\n\n\tGenerated labels and updated fieldbook saved to working directory.")
}
#' Create a general-purpose (gp) label with text aligned in a landscape orientation.
#' @description
#' This is a wrapper that gives more flexibility to the user to design
#' any general-purpose label affixed with QR codes. It gives nine(9) text
#' positions in landscape orientation that can be filled with human-readable text
#' items as specified by the user. Arguments are passed to the `create_label()` function.
#'
#' @returns A PDF file containing plot labels affixed with QR codes, and a data frame of
#' an updated field book; all saved to the default or working directory.
#'
#' @param dat An input data frame or field book that contains plot or label attributes.
#' The order of the columns is not important, and the columns can be any name
#' the user desires.
#' @param get_unique_id Set to 'uuid' if universal unique ids are to be generated.
#' @param unique_id The column identifier in \code{dat} containing unique identifiers or strings to generate QR codes.
#' Set to 'custom' if imported field book already has unique IDs for each plot.
#' @param filename A character prefix or path for the pdf file to be created. Default path
#' is working directory.
#' @param top_left_txt1 The prefix text for top-left row 1.
#' @param top_left_txt2 The prefix text for top-left row 2.
#' @param top_right_txt1 The prefix text for the top-right row 1.
#' @param top_right_txt2 The prefix text for the top-right row 2.
#' @param center_right_txt1 The prefix text for center-right row 1.
#' @param center_right_txt2 The prefix text for center-right row 2.
#' @param center_right_txt3 The prefix text for center-right row 3.
#' @param bottom_left_txt1 The column identifier in \code{dat} containing text for bottom-left row 1.
#' @param bottom_left_txt2 The column identifier in \code{dat} containing text for bottom-left row 2.
#' @param top_left_id1 The column identifier in \code{dat} containing text for top-left row 1.
#' @param top_left_id2 The column identifier in \code{dat} containing text for top-left row 2.
#' @param top_right_id1 The column identifier in \code{dat} containing text for top-right row 1.
#' @param top_right_id2 The column identifier in \code{dat} containing text for top-right row 2.
#' @param center_right_id1 The column identifier in \code{dat} containing text for center-right row 1.
#' @param center_right_id2 The column identifier in \code{dat} containing text for center-right row 2.
#' @param center_right_id3 The column identifier in \code{dat} containing text for center-right row 3.
#' @param bottom_left_id1 The column identifier in \code{dat} containing text for bottom-left row 1.
#' @param bottom_left_id2 The column identifier in \code{dat} containing text for bottom-left row 2.
#' @param ... Additional arguments passed to the \code{create_label} function.
#'
#'@seealso \code{\link{create_label}} and \code{\link{field_label}}
#'
#' @examples
#' library(qrlabelr)
#' df <- data.frame(LOCATION = rep("BAMBEY", 5),
#' PLOT = 1001:1005,
#' ROW = c(rep(1, 3), rep(2, 2)),
#' COLUMN = c(1:3, 1:2),
#' REP = rep(1, 5),
#' IBLOCK = c(rep(1, 3), rep(2, 2)),
#' TREATMENT = paste0("G-", 1:5),
#' SEED_SOURCE = rep("OFF_NUR", 5))
#'
#' df$ids <- paste0(df$LOCATION,'2023', '_PYT', '_', df$PLOT, '_', df$ROW, '_',
#' df$COLUMN)
#' file <- tempfile()
#' \donttest{
#' if(file.exists(file))
#' gp_label(dat = df,
#' wdt = 5,
#' hgt = 2,
#' page_wdt = 8.5,
#' page_hgt = 11,
#' top_mar = 0.75,
#' bot_mar = 0.75,
#' left_mar = 1.75,
#' right_mar = 1.75,
#' numrow = 4L,
#' numcol = 1L,
#' filename = file,
#' font_sz = 20,
#' rname = "Adoma",
#' get_unique_id = "custom",
#' unique_id = 'ids',
#' family = "sans",
#' top_left_txt1 = 'Plot:',
#' top_left_txt2 = 'Row:',
#' top_right_txt1 = 'Rep:',
#' top_right_txt2 = 'Col:',
#' center_right_txt1 = 'iBlock:',
#' center_right_txt2 = 'Seed:',
#' center_right_txt3 = 'Adoma',
#' top_left_id1 = 'PLOT',
#' top_left_id2 = 'ROW',
#' top_right_id1 = 'REP',
#' top_right_id2 = 'COLUMN',
#' center_right_id1 = 'IBLOCK',
#' center_right_id2 = 'SEED_SOURCE',
#' bottom_left_id1 = 'ids',
#' bottom_left_id2 = 'TREATMENT',
#' ec_level = 1)
#' }
#'
#' @export
gp_label <- function(dat,
get_unique_id = c("uuid", "custom"), # Generate unique ids for QR codes
unique_id = NULL,
filename = "PlotLabel",
top_left_txt1 = NULL, # Prefix text for top-left row 1
top_left_txt2 = NULL, # Prefix text for top-left row 2
top_right_txt1 = NULL, # prefix text for top-right row 1
top_right_txt2 = NULL, # Prefix text for top-right row 2
center_right_txt1 = NULL, # Prefix text for center-right row 1
center_right_txt2 = NULL, # prefix text for center-right row 2
center_right_txt3 = NULL, # prefix text for center-right row 3
bottom_left_txt1 = NULL, # Prefix text for bottom-left row 1
bottom_left_txt2 = NULL, # Prefix text for bottom-left row 2
top_left_id1 = NULL, # column id in dat containing text for top-left row 1
top_left_id2 = NULL, # column id in dat containing text for top-left row 2
top_right_id1 = NULL, # column id in dat containing text for top-right row 1
top_right_id2 = NULL, # column id in dat containing text for top-right row 2
center_right_id1 = NULL, # column id in dat containing text for center-right row 1
center_right_id2 = NULL, # column id in dat containing text for center-right row 2
center_right_id3 = NULL, # column id in dat containing text for center-right row 3
bottom_left_id1 = NULL, # column id in dat containing text for bottom-left row 1
bottom_left_id2 = NULL, # column id in dat containing text for bottom-left row 2
...
){
# Assertion for dat argument
assertthat::assert_that(!missing(dat),
msg = "Fieldbook is missing, please provide a fieldbook as a data frame.")
error_prompt <- "Invalid string entered for"
# Text for top-left row 1
if (!is.null(top_left_id1)) {
assertthat::assert_that(assertthat::is.string(top_left_id1),
msg = paste(error_prompt, "'top_left_id1'"))
topleft1 <- paste(top_left_txt1, dat[, top_left_id1])
} else {
topleft1 <- top_left_txt1
}
# Text for top-left row 2
if (!is.null(top_left_id2)) {
assertthat::assert_that(assertthat::is.string(top_left_id2),
msg = paste(error_prompt, "'top_left_id2'"))
topleft2 <- paste(top_left_txt2, dat[, top_left_id2])
} else {
topleft2 <- top_left_txt2
}
# Text for top-right row 1
if (!is.null(top_right_id1)) {
assertthat::assert_that(assertthat::is.string(top_right_id1),
msg = paste(error_prompt, "'top_right_id1'"))
topright1 <- paste(top_right_txt1, dat[, top_right_id1])
} else {
topright1 <- top_right_txt1
}
# Text for top-right row 2
if (!is.null(top_right_id2)) {
assertthat::assert_that(assertthat::is.string(top_right_id2),
msg = paste(error_prompt, "'top_right_id2'"))
topright2 <- paste(top_right_txt2, dat[, top_right_id2])
} else {
topright2 <- top_right_txt2
}
# Text for center-right row 1
if (!is.null(center_right_id1)) {
assertthat::assert_that(assertthat::is.string(center_right_id1),
msg = paste(error_prompt, "'center_right_id1'"))
centerright1 <- paste(center_right_txt1, dat[, center_right_id1])
} else {
centerright1 <- center_right_txt1
}
# Text for center-right row 2
if (!is.null(center_right_id2)) {
assertthat::assert_that(assertthat::is.string(center_right_id2),
msg = paste(error_prompt, "'center_right_id2'"))
centerright2 <- paste(center_right_txt2, dat[, center_right_id2])
} else {
centerright2 <- center_right_txt2
}
# Text for center-right row 3
if (!is.null(center_right_id3)) {
assertthat::assert_that(assertthat::is.string(center_right_id3),
msg = paste(error_prompt, "'center_right_id3'"))
centerright3 <- paste(center_right_txt3, dat[, center_right_id3])
} else {
centerright3 <- center_right_txt3
}
# Text for bottom-left row 1
if (!is.null(bottom_left_id1)) {
assertthat::assert_that(assertthat::is.string(bottom_left_id1),
msg = paste(error_prompt, "'bottom_left_id1'"))
bottomleft1 <- paste(bottom_left_txt1, dat[, bottom_left_id1])
} else {
bottomleft1 <- bottom_left_txt1
}
# Text for bottom-left row 2
if (!is.null(bottom_left_id2)) {
assertthat::assert_that(assertthat::is.string(bottom_left_id2),
msg = paste(error_prompt, "'bottom_left_id2'"))
bottomleft2 <- paste(bottom_left_txt2, dat[, bottom_left_id2])
} else {
bottomleft2 <- bottom_left_txt2
}
# Create unique id: if 'uuid' (i.e. Universal Unique IDs),
# the function generates UUIDs by time randomly. Note that UUIDs are uninformative and not reproducible.
# If 'custom', user must use the 'unique_id' argument to specify the column name
# in fieldbook that denotes custom generated unique IDs.
if (get_unique_id == "uuid") {
UNIQUE_ID <- uuid::UUIDgenerate(use.time = TRUE, n = nrow(dat), output = "string")
} else if (get_unique_id == "custom") {
UNIQUE_ID <- dat[, unique_id]
}
# Create an augmented fieldbook containing unique IDs
updat <- dplyr::mutate(dat, UNIQUE_ID)
colnames(updat)[ncol(updat)] <- 'UNIQUE_ID'
if (colnames(updat)[1] == 'ID') {
colnames(updat)[1] <- 'SN'
} else {
colnames(updat)[1] <- colnames(updat)[1]
}
# File name and timestamp for updated fieldbook
ts <- Sys.time() |> format(format = "%H_%M_%S") |>
paste0("Updated_Fieldbook_", ... = _, ".csv")
utils::write.csv(updat, file = paste0(filename, ts), row.names = FALSE)
# Send updated fieldbook from package environment to global environment
#.GlobalEnv$updated_fieldbook <- list(updated_fieldbook = updat)
do.call(create_label, args = list(top_left_1 = topleft1,
top_left_2 = topleft2,
top_right_1 = topright1,
top_right_2 = topright2,
center_right_1 = centerright1,
center_right_2 = centerright2,
center_right_3 = centerright3,
bottom_left_1 = bottomleft1,
bottom_left_2 = bottomleft2,
unique_id = UNIQUE_ID,
filename = filename, ...))
#cat("\n\n\tGenerated labels and updated fieldbook saved to working directory.")
}
#' Create a general-purpose (gp) label with text aligned in a portrait orientation.
#' @description
#' This is a standalone function that gives more flexibility to the user to
#' design any general-purpose label affixed with QR codes. It gives 10 text
#' positions in portrait orientation that can be filled with human-readable text
#' items as specified by the user.
#'
#' This function creates print-ready customized plot labels affixed with QR codes
#' given the page setup, label dimensions, the number of rows and columns of labels
#' to print per page.
#'
#' @returns A PDF file containing labels affixed with QR codes, saved to the
#' default or working directory.
#'
#' @param dat An input data frame or field book that contains plot attributes.
#' The order of the columns is not important, and the columns can be any name
#' the user desires.
#' @param wdt The label width in inches.
#' @param hgt The label height in inches.
#' @param page_wdt The page width in inches.
#' @param page_hgt The page height in inches.
#' @param top_mar The page top margin in inches.
#' @param bot_mar The page bottom margin in inches.
#' @param left_mar The page left margin in inches.
#' @param right_mar The page right margin in inches.
#' @param numrow The number of label rows per page. It should be an integer.
#' @param numcol The number of label columns per page. It should be an integer.
#' @param filename A character prefix or path for the pdf file to be created. Default path
#' is working directory.
#' @param font_sz The font size to use.
#' @param family The font style to use to print labels.
#' @param rounded Set to TRUE if label has round corners; set to false if label has
#' square corners.
#' @param print_across Set to TRUE to print labels across rows, left to right; else
#' set to FALSE to print labels down columns, top to bottom. Default is \code{TRUE}.
#' @param rect Set to TRUE to draw rectangles around labels, else set to FALSE.
#' Default is \code{TRUE}.
#' @param bot_txt1 The prefix text for bottom text position 1.
#' @param bot_txt2 The prefix text for bottom text position 2.
#' @param bot_txt3 The prefix text for bottom text position 3.
#' @param cent_txt1 The prefix text for center text position 1.
#' @param cent_txt2 The prefix text for center text position 2.
#' @param cent_txt3 The prefix text for center text position 3.
#' @param cent_txt4 The prefix text for center text position 4.
#' @param top_txt1 The prefix text for top text position 1.
#' @param top_txt2 The prefix text for top text position 2.
#' @param top_txt3 The prefix text for top text position 3.
#' @param bot_txt1_id The column identifier in \code{dat} containing text for bottom text position 1.
#' @param bot_txt2_id The column identifier in \code{dat} containing text for bottom text position 2.
#' @param bot_txt3_id The column identifier in \code{dat} containing text for bottom text position 3.
#' @param cent_txt1_id The column identifier in \code{dat} containing text for center text position 1.
#' @param cent_txt2_id The column identifier in \code{dat} containing text for center text position 2.
#' @param cent_txt3_id The column identifier in \code{dat} containing text for center text position 3.
#' @param cent_txt4_id The column identifier in \code{dat} containing text for center text position 4.
#' @param top_txt1_id The column identifier in \code{dat} containing text for top text position 1.
#' @param top_txt2_id The column identifier in \code{dat} containing text for top text position 2.
#' @param top_txt3_id The column identifier in \code{dat} containing text for top text position 3.
#' @param unique_id The column identifier in \code{dat} containing unique identifiers or strings to generate QR codes.
#' @param ec_level The error correction level (`0` - `3`, lowest to highest) for QR codes.
#'
#' @seealso \code{\link{field_label}} and \code{\link{gp_label}}
#'
#' @examples
#' # Create a general-purpose label in a portrait text orientation based on the
#' # 2 x 1 inch Avery 94220 template for laser-jet printers
#' library(qrlabelr)
#' df <- data.frame(LOCATION = rep("BAMBEY", 5),
#' PLOT = 1001:1005,
#' ROW = c(rep(1, 3), rep(2, 2)),
#' COLUMN = c(1:3, 1:2),
#' REP = rep(1, 5),
#' IBLOCK = c(rep(1, 3), rep(2, 2)),
#' TREATMENT = paste0("G-", 1:5),
#' SEED_SOURCE = rep("OFF_NUR", 5))
#'
#' df$ids <- paste0(df$LOCATION,'2023', '_PYT', '_', df$PLOT, '_', df$ROW, '_',
#' df$COLUMN)
#' file <- tempfile()
#' \donttest{
#' if(file.exists(file))
#' gp_label_portrait(
#' dat = df,
#' wdt = 2,
#' hgt = 1,
#' page_wdt = 8.5,
#' page_hgt = 11,
#' top_mar = 0.625,
#' bot_mar = 0.625,
#' left_mar = 0.625,
#' right_mar = 0.625,
#' numrow = 8L,
#' numcol = 3L,
#' filename = file,
#' font_sz = 10,
#' family = 'sans',
#' rounded = TRUE,
#' print_across = TRUE,
#' rect = TRUE,
#' bot_txt1 = 'Rubi',
#' cent_txt2 = 'Rep:',
#' cent_txt3 = 'R:',
#' cent_txt4 = 'r:',
#' top_txt1 = 'P:',
#' top_txt2 = 'B:',
#' bot_txt2_id = 'ids',
#' bot_txt3_id = 'LOCATION',
#' cent_txt1_id = 'TREATMENT',
#' cent_txt2_id = 'REP',
#' cent_txt3_id = 'COLUMN',
#' cent_txt4_id = 'ROW',
#' top_txt1_id = 'PLOT',
#' top_txt2_id = 'IBLOCK',
#' top_txt3_id = 'SEED_SOURCE',
#' unique_id = 'ids',
#' ec_level = 1)
#' }
#'
#' @export
gp_label_portrait <- function(
dat,
wdt = 2, # label width
hgt = 1, # Label height
page_wdt = 8.5, # page width
page_hgt = 11, # page height
top_mar = 0.625, # top margin
bot_mar = 0.625, # bottom margin
left_mar = 0.625, # left margin
right_mar = 0.625, # right margin
numrow = 8L, # number of label rows per page
numcol = 3L, # number of label columns per page
filename = 'PlotLabel', # name for pdf file to be created
font_sz = 8,
family = 'sans', # Font style to use
rounded = TRUE, # Rounded corners
print_across = TRUE, # print across from left to right
rect = TRUE, # draw rectangles around label
bot_txt1 = NULL, # Bottom position position text 1
bot_txt2 = NULL, # Bottom position text 2
bot_txt3 = NULL, # Bottom position text 3
cent_txt1 = NULL, # Center position text 1
cent_txt2 = NULL, # Center position text 2
cent_txt3 = NULL, # Center position text 3
cent_txt4 = NULL, # Center position text 4
top_txt1 = NULL, # Top position text 1
top_txt2 = NULL, # Top position text 2
top_txt3 = NULL, # Top position text 3
bot_txt1_id = NULL, # Bottom position text 1 column ID
bot_txt2_id = NULL, # Bottom position text 2 column ID
bot_txt3_id = NULL, # Bottom position text 3 column ID
cent_txt1_id = NULL, # Center position text 1 column ID
cent_txt2_id = NULL, # Center position text 2 column ID
cent_txt3_id = NULL, # Center position text 3 column ID
cent_txt4_id = NULL, # Center position text 4 column ID
top_txt1_id = NULL, # Top position text 1 column ID
top_txt2_id = NULL, # Top position text 2 column ID
top_txt3_id = NULL, # Top position text 3 column ID
unique_id = NULL, # Column ID for Unique ids for QR codes
ec_level = 3 # qr code error correction level
) {
error_numeric <- "must be a positive numeric value."
error_flag <- "must be a logical or boolean value."
error_string <- "must be string value."
# Function to check for positive values -- may have to be relocated
is.valid_number <- function (x) {
if (x >= 0 && assertthat::is.number(x)) return (TRUE) else return (FALSE)
}
# Used in assertions to check if number is an integer and positive
is.valid_count <- function (x) {
if (x > 0 && assertthat::is.count(x)) return (TRUE) else return (FALSE)
}
# Assertion for dat argument
assertthat::assert_that(!missing(dat),
msg = "Input data frame is missing, please provide a one.")
error_prompt <- "Invalid string entered for"
## Assertions start
# Checking all numeric inputs
assertthat::assert_that(is.valid_number(wdt),
msg = paste("'wdt'", error_numeric))
assertthat::assert_that(is.valid_number(hgt),
msg = paste("'hgt'", error_numeric))
assertthat::assert_that(is.valid_number(page_wdt),
msg = paste("'page_wdt'", error_numeric))
assertthat::assert_that(is.valid_number(page_hgt),
msg = paste("'page_hgt'", error_numeric))
assertthat::assert_that(is.valid_number(top_mar),
msg = paste("'top_mar'", error_numeric))
assertthat::assert_that(is.valid_number(bot_mar),
msg = paste("'bot_mar'", error_numeric))
assertthat::assert_that(is.valid_number(left_mar),
msg = paste("'left_mar'", error_numeric))
assertthat::assert_that(is.valid_number(right_mar),
msg = paste("'right_mar'", error_numeric))
assertthat::assert_that(is.valid_count(numrow),
msg = paste("'numrow'", "must be a positive integer."))
assertthat::assert_that(is.valid_count(numcol),
msg = paste("'numcol'", "must be a positive integer."))
assertthat::assert_that(is.valid_number(font_sz),
msg = paste("'font_sz'", error_numeric))
# Checking all flag inputs
assertthat::assert_that(assertthat::is.flag(rounded),
msg = paste("'rounded'", error_flag))
# Checking all string inputs
assertthat::assert_that(assertthat::is.string(filename),
msg = paste("'filename'", error_string))
assertthat::assert_that(assertthat::is.string(family),
msg = paste("'family'", error_string))
## -- Assertions end
# Calculate space between label columns if any
if (numcol == 1) {
col_space <- 0
} else {
col_space <- (page_wdt - left_mar - right_mar - numcol*wdt)/(numcol-1)
}
# Calculate space between label rows if any
if (numrow == 1) {
row_space <- 0
} else {
row_space <- (page_hgt - top_mar - bot_mar - numrow*hgt)/(numrow-1)
}
# Check if page setup matches label setup per page.
# Error message if either column spaces or the row spaces between labels
# are less than zero
if (col_space < 0 | row_space < 0) {
stop("Page setup does not match label setup per page.")
}
# Get number of labels
n_row <- nrow(dat)
# Bottom text position 1 field
if (!is.null(bot_txt1_id)) {
assertthat::assert_that(assertthat::is.string(bot_txt1_id),
msg = paste(error_prompt, "'bot_txt1_id'"))
text1 <- paste(bot_txt1, dat[, bot_txt1_id])
} else {
text1 <- rep(bot_txt1, n_row)
}
# Bottom text position 2 field
if (!is.null(bot_txt2_id)) {
assertthat::assert_that(assertthat::is.string(bot_txt2_id),
msg = paste(error_prompt, "'bot_txt2_id'"))
text2 <- paste(bot_txt2, dat[, bot_txt2_id])
} else {
text2 <- rep(bot_txt2, n_row)
}
# Bottom text position 3 field
if (!is.null(bot_txt3_id)) {
assertthat::assert_that(assertthat::is.string(bot_txt3_id),
msg = paste(error_prompt, "'bot_txt3_id'"))
text3 <- paste(bot_txt3, dat[, bot_txt3_id])
} else {
text3 <- rep(bot_txt3, n_row)
}
# Center text position 1
if (!is.null(cent_txt1_id)) {
assertthat::assert_that(assertthat::is.string(cent_txt1_id),
msg = paste(error_prompt, "'cent_txt1_id'"))
text4 <- paste(cent_txt1, dat[, cent_txt1_id])
} else {
text4 <- rep(cent_txt1, n_row)
}
# Center text position 2
if (!is.null(cent_txt2_id)) {
assertthat::assert_that(assertthat::is.string(cent_txt2_id),
msg = paste(error_prompt, "'cent_txt2_id'"))
text5 <- paste(cent_txt2, dat[, cent_txt2_id])
} else {
text5 <- rep(cent_txt2, n_row)
}
# Center text position 3
if (!is.null(cent_txt3_id)) {
assertthat::assert_that(assertthat::is.string(cent_txt3_id),
msg = paste(error_prompt, "'cent_txt3_id'"))
text6 <- paste(cent_txt3, dat[, cent_txt3_id])
} else {
text6 <- rep(cent_txt3, n_row)
}
# Center text position 4
if (!is.null(cent_txt4_id)) {
assertthat::assert_that(assertthat::is.string(cent_txt4_id),
msg = paste(error_prompt, "'cent_txt4_id'"))
text7 <- paste(cent_txt4, dat[, cent_txt4_id])
} else {
text7 <- rep(cent_txt4, n_row)
}
# Top text position 1
if (!is.null(top_txt1_id)) {
assertthat::assert_that(assertthat::is.string(top_txt1_id),
msg = paste(error_prompt, "'top_txt1_id'"))
text8 <- paste(top_txt1, dat[, top_txt1_id])
} else {
text8 <- rep(top_txt1, n_row)
}
# Top text position 2
if (!is.null(top_txt2_id)) {
assertthat::assert_that(assertthat::is.string(top_txt2_id),
msg = paste(error_prompt, "'top_txt2_id'"))
text9 <- paste(top_txt2, dat[, top_txt2_id])
} else {
text9 <- rep(top_txt2, n_row)
}
# Top text position 3
if (!is.null(top_txt3_id)) {
assertthat::assert_that(assertthat::is.string(top_txt3_id),
msg = paste(error_prompt, "'top_txt3_id'"))
text10 <- paste(top_txt3, dat[, top_txt3_id])
} else {
text10 <- rep(top_txt3, n_row)
}
# Create QR codes from unique ids
if (!is.null(unique_id)) {
bb <- dat[, unique_id] |> purrr::map(\(x) make_qrcode(ec_level = ec_level, x))
nn <- length(bb) # total number of labels to generate
} else if (is.null(unique_id)) {
stop("Unique IDs for generating QR codes are missing!!")
}
# clean up any open graphical devices if function fails
on.exit(grDevices::graphics.off())
# Generate label positions -- prints across rows of grid layout
if (print_across == TRUE) {
pos <- expand.grid(x = 1:numcol, y = 1:numrow)
} else {
pos <- expand.grid(y = 1:numrow, x = 1:numcol)
}
duplication <- ceiling(nn/nrow(pos))
label_pos <- do.call("rbind", replicate(duplication, pos, simplify = FALSE))
corx <- label_pos$x # label x coordinate
cory <- label_pos$y # label y coordinate
# Create pdf file to be saved in working directory
filename <- paste0(filename, paste0(wdt,'in'), 'x',
paste0(hgt,'in'), Sys.time()) # name of pdf file
filename <- paste0(gsub(":","_", filename), ".pdf")
# Font size to print text on labels
fsize <- font_sz
# Define new coordinates for QR code
wdt1 <- 0.5 * wdt
hgt1 <- 0.5 * hgt
qry <- hgt1/1.2
# Create pdf file
# The argument family specifies the initial/default font family to be
# used. Device independent fonts that can be used include 'sans', 'serif' and
# 'mono', default is sans.
grDevices::pdf(filename,
width = page_wdt,
height = page_hgt,
onefile = TRUE,
family = family) # Letter size paper from Avery
# Grid layout for labels
label_layout <- grid::grid.layout(numrow, numcol,
widths = grid::unit(c(rep(wdt + col_space, numcol-1), wdt), "in"),
heights = grid::unit(c(rep(hgt + row_space, numrow-1), hgt), "in"))
qq <- grid::viewport(x = grid::unit(1, "npc"),
width = grid::unit(wdt1, "in"),
height = grid::unit(qry, "in"),
just = c('right','center'))
# Create a viewport for each label
aa <- grid::viewport(x = grid::unit(0, "npc"),
y = grid::unit(1, "npc"),
width = grid::unit(wdt, "in"),
height = grid::unit(hgt, "in"),
just = c('left','top'))
txt1x <- 0.95*wdt # x coordinate for txt1
txt1y <- 0.05*hgt # y coordinate for txt1
txt2x <- 0.9*wdt # x coordinate for txt2
txt3x <- 0.6*wdt # y coordinate for txt3
txt4x <- 0.5*wdt # y coordinate for txt4
txt5x <- 0.4*wdt # x coordinate for txt5
txt6x <- 0.3*wdt # x coordinate for txt6 and 7
txt7y <- 0.55*hgt # y coordinate for txt7 and 9
txt8x <- 0.2*wdt # x coordinate for txt8 and txt9
txt10x <- 0.05*wdt # y coordinate for txt10
# Viewport for a new page
new.page <- grid::viewport(width = grid::unit(page_wdt, "in"),
height = grid::unit(page_hgt, "in"))
# Create a viewport for each page using grid layout
lab_vp <- grid::viewport(layout = label_layout)
grid::pushViewport(lab_vp)
bold_font <- grid::gpar(fontface = "bold", fontsize = fsize)
bold_font2 <- grid::gpar(fontface = "bold", fontsize = fsize-2)
plain_font2 <- grid::gpar(fontface = "plain", fontsize = fsize-2)
plain_font3 <- grid::gpar(fontface = "plain", fontsize = fsize-4)
bold_font3 <- grid::gpar(fontface = "bold", fontsize = fsize-4)
bold_font4 <- grid::gpar(fontface = "plain", fontsize = floor(fsize/2.5))
# Define progres bar parameters
pro_bar <- txtProgressBar(min = 0, max = nn, style = 3, char = '=')
for (i in seq_len(nn)) {
# set progress bar to chromosome indexing
setTxtProgressBar(pro_bar, value = i)
label_posn <- c(x = corx[i], y = cory[i])
if (all(i != 1 & label_posn == c(1, 1))) {
grid::grid.newpage()
grid::pushViewport(new.page)
grid::pushViewport(lab_vp)
}
grid::pushViewport(grid::viewport(layout.pos.row=label_posn['y'],
layout.pos.col=label_posn['x']))
grid::pushViewport(aa)
# Draw rectangle around labels
if (rect == TRUE) {
if (rounded == TRUE) {
grid::grid.roundrect(gp = grid::gpar(lwd = 0.5))
} else (grid::grid.rect(gp = grid::gpar(lwd = 0.5)))
}
# Add text1 to label (bottom position 1); note coordinates
grid::grid.text(label = text1[i],
x = grid::unit(txt1x, "in"),
y = grid::unit(txt1y, "in"), rot = 90,
gp = bold_font2, hjust = 0, vp = aa)
# Add text2 to label (bottom position 2); note coordinates
grid::grid.text(label = text2[i],
x = grid::unit(txt2x, "in"),
y = grid::unit(txt1y, "in"), rot = 90,
gp = bold_font4, hjust = 0, vp = aa)
# Add text3 to label (bottom position 3); note coordinates
grid::grid.text(label = text3[i],
x = grid::unit(txt3x, "in"),
y = grid::unit(txt1y, "in"), rot = 90,
gp = plain_font3, hjust = 0, vp = aa)
# Add text4 to label (center position 1); note coordinates
grid::grid.text(label = text4[i],
x = grid::unit(txt4x, "in"),
y = grid::unit(txt1y, "in"), rot = 90,
gp = plain_font3, hjust = 0, vp = aa)
# Add text5 to label (center position 2); note coordinates
grid::grid.text(label = text5[i],
x = grid::unit(txt5x, "in"),
y = grid::unit(txt1y, "in"), rot = 90,
gp = bold_font2, just = c(-0.5, 0.5), vp = aa)
# Define viewport for QR code; note coordinates and dimension
grid::pushViewport(qq)
# Add first QR code
grid::grid.draw(bb[[i]])
# grid::popViewport()
# Go back to label viewport
grid::upViewport()
# Add text6 to label (center position 3); note coordinates
grid::grid.text(label = text6[i],
x = grid::unit(txt6x, "in"),
y = grid::unit(txt1y, "in"), rot = 90,
gp = bold_font3, hjust = 0, vp = aa)
# Add text7 to label (center position 4); note coordinates
grid::grid.text(label = text7[i],
x = grid::unit(txt6x, "in"),
y = grid::unit(txt7y, "in"), rot = 90,
gp = bold_font3, hjust = 0, vp = aa)
# Add text8 to label (top position 1); note coordinates
grid::grid.text(label = text8[i],
x = grid::unit(txt8x, "in"),
y = grid::unit(txt1y, "in"), rot = 90,
gp = bold_font3, hjust = 0, vp = aa)
# Add text9 to label (top position 2); note coordinates
grid::grid.text(label = text9[i],
x = grid::unit(txt8x, "in"),
y = grid::unit(txt7y, "in"), rot = 90,
gp = bold_font3, hjust = 0, vp = aa)
# Add text10 to label (top position 3); note coordinates
grid::grid.text(label = text10[i],
x = grid::unit(txt10x, "in"),
y = grid::unit(txt1y, "in"), rot = 90,
gp = bold_font, hjust = 0, vp = aa)
grid::popViewport(2)
} # End of create_label ()
#cat("\n\n\tGenerated labels saved to working directory as a PDF file.")
}
#' Make an enhanced field layout plot with border rows.
#'
#' @description
#' A helper function that adds border rows to the entire perimeter of a
#' field laid out in a rectangular or square grid. Each experimental plot must
#' have a coordinate that is specified by row and column numbers in the
#' grid layout.
#'
#' @param x The input data frame of field book that has row and column
#' coordinates of each plot.
#'
#' @param row_id The string column identifier for ROW in the input field book.
#'
#' @param col_id The string column identifier for COLUMN in the input field book.
#' @param rep_id The string column identifier for REP in the input field book.
#' @param trt_id The string column identifier for TREATMENT in the input field book.
#' @param title The title of the field layout plot.
#' @param text_sz The text size to print treatment names on the tiles.
#' @param axis_title_sz The text size for axis titles.
#' @param xlab A string to label x axis; default is 'Column'.
#' @param ylab A string to label y axis; default is 'Row'.
#' @param border_bg A string specifying the background color for the border rows.
#' @param text_col A string specifying the text color for the border rows.
#'
#'
#' @note
#' This function works best with input field books generated with the 'FielDHub' package
#'
#' @examplesIf rlang::is_installed(c("ggplot2", "desplot"))
#' # Plot a field layout with border rows
#' library(qrlabelr)
#'
#' set.seed(123)
#'
#' add_border(x = data.frame(LOCATION = rep("BAMBEY", 12),
#' PLOT = c(1001:1012),
#' ROW = c(rep(1, 6), rep(2, 6)),
#' COLUMN = c(1:6, 1:6),
#' REP = rep(1, 12),
#' TREATMENT = sample(paste0("G-", 1:12))),
#' text_sz = 3)
#'
#'
#'
#' @returns A 'ggplot2' graphical object of field layout with border rows around the entire perimeter.
#'
#' @export
#'
add_border <- function (x,
row_id = "ROW",
col_id = "COLUMN",
rep_id = "REP",
trt_id = "TREATMENT",
title = "Field layout",
text_sz = 3,
axis_title_sz = 12,
xlab = "Column",
ylab = "Row",
border_bg = "grey80",
text_col = "grey10"
) {
if (!inherits(x, what = "data.frame")) {
stop("Input field book must be a data frame object.")
}
# Subset relevant columns from input field book
ROW <- x[, row_id]
COLUMN <- x[, col_id]
REP <- x[, rep_id]
TREATMENT <- x[, trt_id]
dat <- data.frame(ROW, COLUMN, REP, TREATMENT)
# Get the number of rows, columns, reps and trts
nrows <- length(unique(dat$ROW))
ncols <- length(unique(dat$COLUMN))
nrep <- length(unique(dat$REP))
ntrt <- length(unique(dat$TREATMENT))
# Row and column ids for border rows
# bottom border row = 0, top border row = max row number + 1
# left border row = 0, right border row = max col number + 1
start_row_bor <- start_col_bor <- 0
end_row_bor <- nrows + 1
end_col_bor <- ncols + 1
# Generate border rows
bb <- data.frame(ROW = start_row_bor,
COLUMN = c(0, unique(dat$COLUMN), end_col_bor),
REP = NA,
TREATMENT = 'Border')
tb <- data.frame(ROW = end_row_bor,
COLUMN = c(0, unique(dat$COLUMN), end_col_bor),
REP = NA,
TREATMENT = 'Border')
lb <- data.frame(ROW = c(unique(dat$ROW)),
COLUMN = start_col_bor,
REP = NA,
TREATMENT = 'Border')
rb <- data.frame(ROW = c(unique(dat$ROW)),
COLUMN = end_col_bor,
REP = NA,
TREATMENT = 'Border')
# Plot field layout
pp <- ggplot2::ggplot(dat, ggplot2::aes(x = COLUMN, y = ROW)) +
ggplot2::theme_classic() +
ggplot2::geom_tile(ggplot2::aes(fill = TREATMENT), col = "white") +
ggplot2::geom_text(ggplot2::aes(label = TREATMENT), size = text_sz, col = "grey5") +
desplot::geom_tileborder(ggplot2::aes(group = 1, grp = REP), lwd = 1.5) +
ggplot2::scale_x_continuous(breaks = 1:max(dat$COLUMN)) +
ggplot2::scale_y_continuous(breaks = 1:max(dat$ROW)) +
ggplot2::labs(x = xlab, y = ylab, title = title) +
ggplot2::theme(axis.title = ggplot2::element_text(size = axis_title_sz),
legend.position = 'none',
axis.line = ggplot2::element_blank(),
axis.ticks = ggplot2::element_blank(),
axis.text.x = ggplot2::element_blank(),
axis.text.y= ggplot2::element_blank())
# Add bottom border
pp <- pp + ggplot2::annotate(geom = "tile", x = bb$COLUMN, y = bb$ROW, fill = border_bg) +
ggplot2::annotate(geom = "text", x = max(bb$COLUMN)/2, y = min(bb$ROW),
label = "Bottom border", color = text_col, size = text_sz+1, fontface = 'bold')
# Add top border
pp <- pp + ggplot2::annotate(geom = "tile", x = tb$COLUMN, y = tb$ROW, fill = border_bg) +
ggplot2::annotate(geom = "text", x = max(tb$COLUMN)/2, y = min(tb$ROW),
label = "Top border", color = text_col, size = text_sz+1, fontface = 'bold')
# Add left border
pp <- pp + ggplot2::annotate(geom = "tile", x = lb$COLUMN, y = lb$ROW, fill = border_bg) +
ggplot2::annotate(geom = "text", x = min(bb$COLUMN), y = max(tb$ROW)/2,
label = "Left border", color = text_col, size = text_sz+1,
fontface = 'bold', angle = 90)
# Add right border
pp <- pp + ggplot2::annotate(geom = "tile", x = rb$COLUMN, y = rb$ROW, fill = border_bg) +
ggplot2::annotate(geom = "text", x = max(bb$COLUMN), y = max(tb$ROW)/2,
label = "Right border", color = text_col, size = text_sz+1,
fontface = 'bold', angle = 90)
return(pp)
}
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.