R/cropmarkGrob.R

In piecepackr: Board Game Graphics

#' Draw crop marks with grid
#'
#' `grid.cropmark()` draws \dQuote{crop marks} to the active graphics device.
#' `cropmarkGrob()` is its grid grob counterpart.
#' Intended for use in adding crop marks around
#' game pieces in print-and-play layouts.
#'
#' @inheritParams pieceGrob
#' @param bleed Bleed zone size to assume:
#'              \itemize{
#'                 \item{If `bleed` is a [grid::unit()] simply use it}
#'                 \item{If `bleed` is numeric then convert via `grid::unit(bleed, default.units)`}
#'                 \item{If `bleed` is `TRUE` assume 1/8 inch bleed zone size}
#'                 \item{If `bleed` is `FALSE` assume 0 inch bleed zone size}
#'              }
#' @param cm_select A string of integers from "1" to "8" indicating which
#'                  crop marks to draw.  "1" represents the top right crop mark
#'                  then we proceeding clockwise to "8" which represents the
#'                  top left crop mark.
#'                  Default "12345678" draws all eight crop marks.
#' @param cm_width Width of crop mark.
#' @param cm_length Length of crop mark.
#' @return A grid grob.
#' @examples
#' if (requireNamespace("grid", quietly = TRUE) &&
#'     piecepackr:::device_supports_unicode()) {
#'   cfg <- pp_cfg(list(mat_color = "pink", mat_width=0.05, border_color=NA))
#'   grid::grid.newpage()
#'   df <- data.frame(piece_side = "tile_face", suit = 2, rank = 2,
#'                    x = 2, y = 2, angle = 0,
#'                    stringsAsFactors = FALSE)
#'   pmap_piece(df, grid.cropmark, cfg = cfg, default.units = "in")
#'   pmap_piece(df, grid.piece, cfg = cfg, default.units = "in", bleed=TRUE)
#' }
#' if (requireNamespace("grid", quietly = TRUE) &&
#'     piecepackr:::device_supports_unicode()) {
#'   grid::grid.newpage()
#'   df <- data.frame(piece_side = "coin_back", suit = 2, rank = 2,
#'                    x = 2, y = 2, angle = 0,
#'                    stringsAsFactors = FALSE)
#'   pmap_piece(df, grid.cropmark, cfg = cfg, default.units = "in", bleed=TRUE)
#'   pmap_piece(df, grid.piece, cfg = cfg, default.units = "in", bleed=TRUE)
#' }
#' @name grid.cropmark
NULL

#' @rdname grid.cropmark
#' @export
cropmarkGrob <- function(
	...,
	piece_side = "tile_back",
	suit = NA,
	rank = NA,
	cfg = getOption("piecepackr.cfg", pp_cfg()),
	x = unit(0.5, "npc"),
	y = unit(0.5, "npc"),
	angle = 0,
	width = NA,
	height = NA,
	scale = 1,
	default.units = "npc",
	envir = getOption("piecepackr.envir"),
	name = NULL,
	gp = gpar(),
	vp = NULL,
	bleed = unit(0.125, "in"),
	cm_select = "12345678",
	cm_width = unit(0.25, "mm"),
	cm_length = unit(0.125, "in")
) {
	if (is_angle(angle)) {
		angle <- as.double(angle, "degrees")
	}

	gTree(
		piece_side = piece_side,
		suit = suit,
		rank = rank,
		cfg = cfg,
		x = x,
		y = y,
		angle = angle,
		width = width,
		height = height,
		default.units = default.units,
		envir = envir,
		scale = scale,
		bleed = bleed,
		cm_select = cm_select,
		cm_width = cm_width,
		cm_length = cm_length,
		name = name,
		gp = gp,
		vp = vp,
		cl = "pp_cropmark"
	)
}

#' @rdname grid.cropmark
#' @param ... `cropmarkGrob()` ignores; `grid.cropmark()` passes to `cropmarkGrob()`.
#' @export
grid.cropmark <- function(..., draw = TRUE) {
	grob <- cropmarkGrob(...)
	if (draw) {
		grid.draw(grob)
		invisible(grob)
	} else {
		grob
	}
}

#' @export
makeContext.pp_cropmark <- function(x) {
	x$gp$fill <- x$gp$fill %||% x$gp$col %||% get.gpar("col")$col
	x$gp$col <- NA
	x
}

#' @export
makeContent.pp_cropmark <- function(x) {
	nn <- max(lengths(list(
		x$piece_side,
		x$suit,
		x$rank,
		x$x,
		x$y,
		x$angle,
		x$width,
		x$height,
		x$scale,
		x$bleed,
		x$cm_select,
		x$cm_width,
		x$cm_length
	)))
	piece_side <- rep(x$piece_side, length.out = nn)
	suit <- rep(x$suit, length.out = nn)
	rank <- rep(x$rank, length.out = nn)
	xc <- rep(x$x, length.out = nn)
	yc <- rep(x$y, length.out = nn)
	angle <- rep(x$angle, length.out = nn)

	width <- rep(x$width, length.out = nn)
	height <- rep(x$height, length.out = nn)

	scale <- rep(x$scale, length.out = nn)
	bleed <- rep(x$bleed, length.out = nn)

	cfg <- get_cfg(x$cfg, x$envir)
	cfg <- rep(c(cfg), length.out = nn)

	cm_select <- rep(x$cm_select, length.out = nn)
	cm_width <- rep(x$cm_width, length.out = nn)
	cm_length <- rep(x$cm_length, length.out = nn)

	gl <- gList()
	for (i in seq(nn)) {
		name <- paste0(".", i)
		gl[[i]] <- cropmarkGrobHelper(
			piece_side[i],
			suit[i],
			rank[i],
			cfg[[i]],
			xc[i],
			yc[i],
			angle[i],
			width[i],
			height[i],
			x$default.units,
			scale[i],
			name,
			bleed[i],
			cm_select[i],
			cm_width[i],
			cm_length[i]
		)
	}
	setChildren(x, gl)
}

cropmarkGrobHelper <- function(
	piece_side = "tile_back",
	suit = NA,
	rank = NA,
	cfg = pp_cfg(),
	x = unit(0.5, "npc"),
	y = unit(0.5, "npc"),
	angle = 0,
	width = NA,
	height = NA,
	default.units = "npc",
	scale = 1,
	name = "",
	bleed = FALSE,
	cm_select = "12345678",
	cm_width = unit(0.25, "mm"),
	cm_length = unit(0.125, "in")
) {
	if (is.na(width) || is.na(height)) {
		cfg <- as_pp_cfg(cfg)
		rank <- impute_rank(piece_side, rank, cfg)
		suit <- impute_suit(piece_side, suit, cfg)
		if (is.na(width)) {
			width <- inch(cfg$get_width(piece_side, suit, rank))
		}
		if (is.na(height)) height <- inch(cfg$get_height(piece_side, suit, rank))
	}

	if (is.na(angle)) {
		angle <- 0
	} else {
		angle <- angle %% 360
	}

	if (isTRUE(bleed)) {
		bleed <- unit(0.125, "in")
	}
	if (isFALSE(bleed)) {
		bleed <- unit(0, "in")
	}
	if (!is.unit(bleed)) {
		bleed <- unit(bleed, default.units)
	}

	if (!is.unit(x)) {
		x <- unit(x, default.units)
	}
	if (!is.unit(y)) {
		y <- unit(y, default.units)
	}
	if (!is.unit(width)) {
		width <- unit(width, default.units)
	}
	if (!is.unit(height)) {
		height <- unit(height, default.units)
	}
	if (!is.unit(cm_width)) {
		cm_width <- unit(cm_width, default.units)
	}
	if (!is.unit(cm_length)) {
		cm_length <- unit(cm_length, default.units)
	}

	width <- scale * width
	height <- scale * height
	vp <- viewport(
		x = x,
		y = y,
		angle = angle,
		width = width + 2 * bleed + 2 * cm_length,
		height = height + 2 * bleed + 2 * cm_length
	)

	xc <- unit(0.5, "npc")
	yc <- unit(0.5, "npc")

	if (grepl("1", cm_select)) {
		cm1 <- rectGrob(
			x = xc + 0.5 * width,
			y = yc + 0.5 * height + bleed + 0.5 * cm_length,
			width = cm_width,
			height = cm_length,
			name = "crop_mark_1"
		)
	} else {
		cm1 <- nullGrob(name = "crop_mark_1")
	}

	if (grepl("2", cm_select)) {
		cm2 <- rectGrob(
			x = xc + 0.5 * width + bleed + 0.5 * cm_length,
			y = yc + 0.5 * height,
			width = cm_length,
			height = cm_width,
			name = "crop_mark_2"
		)
	} else {
		cm2 <- nullGrob(name = "crop_mark_2")
	}

	if (grepl("3", cm_select)) {
		cm3 <- rectGrob(
			x = xc + 0.5 * width + bleed + 0.5 * cm_length,
			y = yc - 0.5 * height,
			width = cm_length,
			height = cm_width,
			name = "crop_mark_3"
		)
	} else {
		cm3 <- nullGrob(name = "crop_mark_3")
	}

	if (grepl("4", cm_select)) {
		cm4 <- rectGrob(
			x = xc + 0.5 * width,
			y = yc - 0.5 * height - bleed - 0.5 * cm_length,
			width = cm_width,
			height = cm_length,
			name = "crop_mark_4"
		)
	} else {
		cm4 <- nullGrob(name = "crop_mark_4")
	}

	if (grepl("5", cm_select)) {
		cm5 <- rectGrob(
			x = xc - 0.5 * width,
			y = yc - 0.5 * height - bleed - 0.5 * cm_length,
			width = cm_width,
			height = cm_length,
			name = "crop_mark_5"
		)
	} else {
		cm5 <- nullGrob(name = "crop_mark_5")
	}

	if (grepl("6", cm_select)) {
		cm6 <- rectGrob(
			x = xc - 0.5 * width - bleed - 0.5 * cm_length,
			y = yc - 0.5 * height,
			width = cm_length,
			height = cm_width,
			name = "crop_mark_6"
		)
	} else {
		cm6 <- nullGrob(name = "crop_mark_6")
	}

	if (grepl("7", cm_select)) {
		cm7 <- rectGrob(
			x = xc - 0.5 * width - bleed - 0.5 * cm_length,
			y = yc + 0.5 * height,
			width = cm_length,
			height = cm_width,
			name = "crop_mark_7"
		)
	} else {
		cm7 <- nullGrob(name = "crop_mark_7")
	}

	if (grepl("8", cm_select)) {
		cm8 <- rectGrob(
			x = xc - 0.5 * width,
			y = yc + 0.5 * height + bleed + 0.5 * cm_length,
			width = cm_width,
			height = cm_length,
			name = "crop_mark_8"
		)
	} else {
		cm8 <- nullGrob(name = "crop_mark_8")
	}
	name <- paste0("crop_mark", name)

	grobTree(cm1, cm2, cm3, cm4, cm5, cm6, cm7, cm8, name = name, vp = vp)
}