Skip to content

Commit

Permalink
Simplified input format for location arg in ph_with_* functions (d…
Browse files Browse the repository at this point in the history 
…avidgohel#623)

Instead of a `location` object created by the `ph_location_*` function family,
`ph_with_*` functions now resolves certain short form input into corresponding
`location` objects. For example, instead of using `ph_location_label("<label>")`
you can now simply pass the `"<label>"` to the `location` arg. The functionn will
convert the string into the corresponding location object automatically. Other
examples are `"body [1]"` for `ph_location_type(type = "body", type_idx = 1)`,
or the integer `1` for `ph_location_id(id = 1)`.
  • Loading branch information
@markheckmann
markheckmann committed Jan 25, 2025
1 parent 5acaedd commit 6edce55
Show file tree
Hide file tree
Showing 5 changed files with 239 additions and 54 deletions.
26 changes: 13 additions & 13 deletions NAMESPACE
View file
Original file line number Diff line number Diff line change
Expand Up @@ -42,19 +42,6 @@ S3method(length,rpptx)
S3method(length,rxlsx)
S3method(ph_from_location,location_label)
S3method(ph_from_location,location_type)
S3method(ph_with,block_list)
S3method(ph_with,character)
S3method(ph_with,data.frame)
S3method(ph_with,empty_content)
S3method(ph_with,external_img)
S3method(ph_with,factor)
S3method(ph_with,fpar)
S3method(ph_with,gg)
S3method(ph_with,logical)
S3method(ph_with,numeric)
S3method(ph_with,plot_instr)
S3method(ph_with,unordered_list)
S3method(ph_with,xml_document)
S3method(print,block_caption)
S3method(print,block_pour_docx)
S3method(print,block_section)
Expand Down Expand Up @@ -268,6 +255,19 @@ export(ph_location_type)
export(ph_remove)
export(ph_slidelink)
export(ph_with)
export(ph_with.block_list)
export(ph_with.character)
export(ph_with.data.frame)
export(ph_with.empty_content)
export(ph_with.external_img)
export(ph_with.factor)
export(ph_with.fpar)
export(ph_with.gg)
export(ph_with.logical)
export(ph_with.numeric)
export(ph_with.plot_instr)
export(ph_with.unordered_list)
export(ph_with.xml_document)
export(plot_instr)
export(plot_layout_properties)
export(pptx_summary)
Expand Down
6 changes: 6 additions & 0 deletions NEWS.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,12 @@

## Issues

- Simplified input format for `location` arg in `ph_with_*` functions (#623). Instead of a `location` object
created by the `ph_location_*` function family, `ph_with_*` functions now resolves certain short form
input into corresponding `location` objects. For example, instead of using `ph_location_label("<label>")`
you can now simply pass the `"<label>"` to the `location` arg. The functionn will convert the string into
the corresponding location object automatically. Other examples are `"body [1]"` for
`ph_location_type(type = "body", type_idx = 1)`, or the integer `1` for `ph_location_id(id = 1)`
- Add `slide_visible()` to get and set the visibility of slides (#622).
- debug selector for `ph_remove()` (see #625) that was not working
for rvg outputs.
Expand Down
203 changes: 188 additions & 15 deletions R/ph_location.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -100,7 +100,7 @@ as_ph_location <- function(x, ...) {
cli::cli_abort(
c("{.arg x} must be a data frame.",
"x" = "You provided {.cls {class(x)[1]}} instead.")
)
)
}
ref_names <- c(
"width", "height", "left", "top", "ph_label", "ph", "type", "rotation", "fld_id", "fld_type"
Expand All @@ -113,6 +113,11 @@ as_ph_location <- function(x, ...) {
}


is_ph_location <- function(x) {
inherits(x, "location_num") || inherits(x, "location_str")
}


#' @export
#' @title Eval a location on the current slide
#' @description Eval a shape location against the current slide.
Expand All @@ -135,6 +140,7 @@ fortify_location <- function( x, doc, ... ){
UseMethod("fortify_location")
}

# _________________ ----
# main ----

#' @export
Expand Down Expand Up @@ -189,7 +195,7 @@ ph_location <- function(left = 1, top = 1, width = 4, height = 3,
...){

x <- list(left = left, top = top, width = width, height = height,
ph_label = newlabel, ph = NA_character_, bg = bg, rotation = rotation, ln = ln, geom = geom, fld_type = NA_character_, fld_id = NA_character_)
ph_label = newlabel, ph = NA_character_, bg = bg, rotation = rotation, ln = ln, geom = geom, fld_type = NA_character_, fld_id = NA_character_)

class(x) <- c("location_manual", "location_str")
x
Expand Down Expand Up @@ -227,12 +233,12 @@ fortify_location.location_manual <- function( x, doc, ...){
#' print(doc, target = tempfile(fileext = ".pptx") )
#' @export
ph_location_template <- function(left = 1, top = 1, width = 4, height = 3,
newlabel = "", type = NULL, id = 1,
...){
newlabel = "", type = NULL, id = 1,
...){

x <- list(left = left, top = top, width = width, height = height,
ph_label = newlabel, ph = NA_character_,
type = type, id = id)
ph_label = newlabel, ph = NA_character_,
type = type, id = id)

class(x) <- c("location_template", "location_str")
x
Expand All @@ -246,7 +252,7 @@ fortify_location.location_template <- function( x, doc, ...){
ph <- sprintf('<p:ph type="%s"/>', "body")
}
x <- ph_location(left = x$left, top = x$top, width = x$width, height = x$height,
label = x$ph_label)
label = x$ph_label)
x$ph <- ph
fortify_location.location_manual(x)
}
Expand Down Expand Up @@ -355,10 +361,10 @@ fortify_location.location_type <- function(x, doc, ...) {
# to avoid a breaking change, the deprecated id is passed along.
# As type_idx uses a different index order than id, this is necessary until the id arg is removed.
out <- get_ph_loc(doc,
layout = layout, master = master,
type = x$type, position_right = x$position_right,
position_top = x$position_top, type_idx = x$type_idx,
id = x$id, ph_id = NULL # id is deprecated and will be removed soon
layout = layout, master = master,
type = x$type, position_right = x$position_right,
position_top = x$position_top, type_idx = x$type_idx,
id = x$id, ph_id = NULL # id is deprecated and will be removed soon
)
if (!is.null(x$label)) {
out$ph_label <- x$label
Expand Down Expand Up @@ -501,8 +507,8 @@ fortify_location.location_left <- function( x, doc, ...){
args <- list(...)
master <- if(is.null(args$master)) unique( xfrm$master_name ) else args$master
out <- get_ph_loc(doc, layout = "Two Content", master = master,
type = "body", position_right = FALSE,
position_top = TRUE)
type = "body", position_right = FALSE,
position_top = TRUE)
if( !is.null(x$label) )
out$ph_label <- x$label
out
Expand Down Expand Up @@ -542,8 +548,8 @@ fortify_location.location_right <- function( x, doc, ...){
args <- list(...)
master <- ifelse(is.null(args$master), unique( xfrm$master_name ), args$master)
out <- get_ph_loc(doc, layout = "Two Content", master = master,
type = "body", position_right = TRUE,
position_top = TRUE)
type = "body", position_right = TRUE,
position_top = TRUE)
if( !is.null(x$label) )
out$ph_label <- x$label
out
Expand Down Expand Up @@ -632,4 +638,171 @@ fortify_location.location_id <- function(x, doc, ...) {
out
}

# _________________ ----
# resolve ----


# convert simplified location format, i.e. a numeric or string (e.g. "body [1]")
# into corresponding location object. The following short forms are available:
# - integer of length 1 = ph_location_id()
# - integer of length 4 = ph_location_position()
# - keyword left,right,fullsize = ph_location_left(), ph_location_right(), ph_location_fullsize()
# - type keyword + type index = ph_location_type() [e.g. body, title, ctrTitle, subTitle, dt, ftr, sldNum = ]
# - other string = ph_location_label()
#
resolve_location <- function(x) {
if (is_ph_location(x)) {
return(x)
}
if (is.numeric(x)) {
return(resolve_location_from_numeric(x))
}
if (is.character(x)) {
return(resolve_location_from_character(x))
}
cli::cli_abort("Cannot resolve class {.cls {class(x)[1]}} into a location")
}


resolve_location_from_numeric <- function(x) {
# length 1 integer => ph_location_id()
# length 4 numeric => ph_location()
len <- length(x)
if (len == 1) {
if (!is_integerish(x)) {
cli::cli_abort(
c("{.arg location} is a length 1 {.cls {class(x)[1]}}: {.val {x}}",
"x" = "If length 1, {.arg location} requires {.cls integer}"
),
call = NULL
)
}
location <- resolve_ph_location_id(x)
} else if (len == 4) {
location <- resolve_ph_location(x)
} else {
cli::cli_abort(
c("{.arg location} has incorrect length.",
"x" = "Numeric vector passed to {.arg location} must have length 1 or 4"
),
call = NULL
)
}
location
}


resolve_ph_location_id <- function(x) {
if (x < 0) {
cli::cli_abort(
c("{.arg location} is negative.",
"x" = "Integers passed to {.arg location} must be positive"
),
call = NULL
)
}
ph_location_id(id = x)
}


# checks named numeric vector with position info [for ph_location_position()].
# c(left =, top =, width =, height = )
#
fortify_named_location_position <- function(x) {
args <- names(x)
expected <- c("left", "top", "width", "height")
matched <- pmatch(args, expected, duplicates.ok = TRUE)
nms_new <- ifelse(is.na(matched), NA, expected[matched])

# unknown position
i_na <- is.na(nms_new)
if (any(i_na)) {
cli::cli_abort(
c("Found {sum(i_na)} unknown name{?s} in {.arg location}: {.val {args[i_na]}}",
"x" = "{.arg location} understands {.val {expected}}",
"i" = cli::col_silver("Partial name matching is supported")
)
)
}
# duplicate position
ii_dupes <- duplicated(nms_new)
if (any(ii_dupes)) {
cli::cli_abort(
c("Duplicate entries in {.arg location}: {.val {unique(nms_new[ii_dupes])}}",
"x" = "Each name in {.arg location} must be unique",
"i" = cli::col_silver("Partial name matching is supported")
)
)
}
# missing position
missings <- setdiff(expected, nms_new)
if (length(missings) > 0) {
cli::cli_abort(
c("Missing {.val {missings}} in {.arg location}",
"x" = "{.arg location} requinms_new {.val {expected}}",
"i" = cli::col_silver("Partial name matching is supported")
)
)
}
setNames(x, nms_new)
}


resolve_ph_location <- function(x) {
if (is.null(names(x))) {
names(x) <- c("left", "top", "width", "height")
}
x <- fortify_named_location_position(x)
do.call(ph_location, as.list(x))
}


resolve_location_from_character <- function(x) {
# - keyword left, => ph_location_left()
# right => ph_location_right()
# fullsize => ph_location_fullsize()
# - type: body, title, ctrTitle, subTitle, dt, ftr, sldNum
# => ph_location_type()
# - label: <any> => ph_location_label()
if (x == "left") {
location <- ph_location_left()
} else if (x == "right") {
location <- ph_location_right()
} else if (x == "fullsize") {
location <- ph_location_fullsize()
} else if (has_ph_type_format(x)) {
location <- do.call(ph_location_type, get_ph_type_info(x))
} else {
location <- ph_location_label(x)
}
}

# matches pattern "type [type_idx ]",
# e.g. "body", "body[1]", ""body [1]", "body [1]" => all identical
.ph_type_pattern <- "^(body|title|ctrTitle|subTitle|dt|ftr|sldNum)\\s*(\\[\\d+\\])?$"


has_ph_type_format <- function(x) {
grepl(.ph_type_pattern, trimws(x))
}


# extract type name and idx from squared brackets
# e.g. "body [1]" => list(type = "body", type_idx = 1)
get_ph_type_info <- function(x) {
x <- trimws(x)
matches <- regexec(.ph_type_pattern, x)
extracted <- regmatches(x, matches)[[1]]
l <- setNames(as.list(extracted), c("input", "type", "type_idx"))
l$type_idx <- ifelse(l$type_idx == "", "[1]", l$type_idx) # if brackets with index is missing, "[1]" is used
l$type_idx <- extract_integers(l$type_idx)
l
}


# extract integers from text, e.g. "[1]" => 1
extract_integers <- function(x) {
matches <- gregexpr("\\d+", x)
v <- unlist(regmatches(x, matches))
as.numeric(v)
}
6 changes: 6 additions & 0 deletions R/ppt_ph_with_methods.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -165,6 +165,12 @@
#'
#' \if{html}{\figure{ph_with_doc_1.png}{options: width=80\%}}
ph_with <- function(x, value, location, ...) {
location <- resolve_location(location)
.ph_with(x, value, location, ...)
}


.ph_with <- function(x, value, location, ...) {
UseMethod("ph_with", value)
}

Expand Down
Loading

0 comments on commit 6edce55

Please sign in to comment.