Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

fix: ph_location_type() - throw error for out of range type id (fix #602) and more info if ph type not present (close #601) #603

Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
Type: Package
Package: officer
Title: Manipulation of Microsoft Word and PowerPoint Documents
Version: 0.6.7.009
Version: 0.6.7.010
Authors@R: c(
person("David", "Gohel", , "[email protected]", role = c("aut", "cre")),
person("Stefan", "Moog", , "[email protected]", role = "aut"),
Expand Down
2 changes: 2 additions & 0 deletions NEWS.md
Original file line number Diff line number Diff line change
Expand Up @@ -15,6 +15,8 @@ For example, `slideLayout2.xml` will now preceed `slideLayout10.xml`. Before, al
- `layout_properties()` now returns all placeholders in case of multiple master (#597). Also, the internal `xfrmize()`
now sorts the resulting data by placeholder position. This yields an intuitive order, with placeholders sorted from
top to bottom and left to right.
- `ph_location_type()` now throws an error if the `id` for a `type` is out of range (#602) and a more
informative error message if the type is not present in layout (#601).

## Features

Expand Down
71 changes: 46 additions & 25 deletions R/ph_location.R
Original file line number Diff line number Diff line change
@@ -1,35 +1,50 @@
get_ph_loc <- function(x, layout, master, type, position_right, position_top, id = NULL){

props <- layout_properties( x, layout = layout, master = master )
get_ph_loc <- function(x, layout, master, type, position_right, position_top, id = NULL) {
props <- layout_properties(x, layout = layout, master = master)
types_on_layout <- unique(props$type)
props <- props[props$type %in% type, , drop = FALSE]

if( nrow(props) < 1) {
stop("no selected row")
nr <- nrow(props)
if (nr < 1) {
cli::cli_abort(c(
"Found no placeholder of type {.val {type}} on layout {.val {layout}}.",
"x" = "Available types are {.val {types_on_layout}}",
"i" = cli::col_grey("see {.code layout_properties(x, '{layout}', '{master}')}")
), call = NULL)
}
if( !is.null(id) ){
props <- props[id,, drop = FALSE]

if (!is.null(id)) {
if (!id %in% 1L:nr) {
cli::cli_abort(
c(
"{.arg id} is out of range.",
"x" = "Must be between {.val {1L}} and {.val {nr}} for ph type {.val {type}}.",
"i" = cli::col_grey("see {.code layout_properties(x, '{layout}', '{master}')} for all phs with type '{type}'")
),
call = NULL
)
}
props <- props[id, , drop = FALSE]
} else {
if(position_right){
props <- props[props$offx + 0.0001 > max(props$offx),]
if (position_right) {
props <- props[props$offx + 0.0001 > max(props$offx), ]
} else {
props <- props[props$offx - 0.0001 < min(props$offx),]
props <- props[props$offx - 0.0001 < min(props$offx), ]
}
if(position_top){
props <- props[props$offy - 0.0001 < min(props$offy),]
if (position_top) {
props <- props[props$offy - 0.0001 < min(props$offy), ]
} else {
props <- props[props$offy + 0.0001 > max(props$offy),]
props <- props[props$offy + 0.0001 > max(props$offy), ]
}
}


if( nrow(props) > 1) {
warning("more than a row have been selected")
if (nrow(props) > 1) {
cli::cli_alert_warning("More than one placeholder selected.")
}
props <- props[, c("offx", "offy", "cx", "cy", "ph_label", "ph", "type", "fld_id", "fld_type", "rotation")]
names(props) <- c("left", "top", "width", "height", "ph_label", "ph", "type", "fld_id", "fld_type", "rotation")
as_ph_location(props)
}


as_ph_location <- function(x, ...){
if( !is.data.frame(x) ){
stop("x should be a data.frame")
Expand Down Expand Up @@ -229,18 +244,25 @@ fortify_location.location_template <- function( x, doc, ...){
#'
#' fileout <- tempfile(fileext = ".pptx")
#' print(doc, target = fileout)
ph_location_type <- function( type = "body", position_right = TRUE, position_top = TRUE, newlabel = NULL, id = NULL, ...){

ph_types <- c("ctrTitle", "subTitle", "dt", "ftr", "sldNum", "title", "body",
"pic", "chart", "tbl", "dgm", "media", "clipArt")
if(!type %in% ph_types){
stop("argument type ('", type, "') expected to be a value of ",
paste0(shQuote(ph_types), collapse = ", "), ".")
ph_location_type <- function(type = "body", position_right = TRUE, position_top = TRUE, newlabel = NULL, id = NULL, ...) {
ph_types <- c(
"ctrTitle", "subTitle", "dt", "ftr", "sldNum", "title", "body",
"pic", "chart", "tbl", "dgm", "media", "clipArt"
)
if (!type %in% ph_types) {
cli::cli_abort(
c("type {.val {type}} is unknown.",
"x" = "Must be one of {.or {.val {ph_types}}}"
),
call = NULL
)
}
x <- list(type = type, position_right = position_right, position_top = position_top, id = id, label = newlabel)
class(x) <- c("location_type", "location_str")
x
}


#' @export
fortify_location.location_type <- function( x, doc, ...){

Expand All @@ -250,7 +272,6 @@ fortify_location.location_type <- function( x, doc, ...){

layout <- ifelse(is.null(args$layout), unique( xfrm$name ), args$layout)
master <- ifelse(is.null(args$master), unique( xfrm$master_name ), args$master)

out <- get_ph_loc(doc, layout = layout, master = master,
type = x$type, position_right = x$position_right,
position_top = x$position_top, id = x$id)
Expand Down
31 changes: 29 additions & 2 deletions tests/testthat/test-pptx-add.R
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
test_that("add wrong arguments", {
doc <- read_pptx()
expect_error(add_slide(doc, "Title and blah", "Office Theme"))
expect_error(add_slide(doc, "Title and Content", "Office Tddheme"))
expect_error(add_slide(doc, "Title and blah", "Office Theme"), fixed = TRUE)
expect_error(add_slide(doc, "Title and Content", "Office Tddheme"), fixed = TRUE)
})

test_that("add simple elements into placeholder", {
Expand Down Expand Up @@ -271,6 +271,7 @@ test_that("empty_content in pptx", {
expect_equal(slide_summary(doc)$cx, 2)
})


test_that("pptx ph locations", {
doc <- read_pptx()
doc <- add_slide(doc, "Title and Content", "Office Theme")
Expand Down Expand Up @@ -334,6 +335,32 @@ test_that("pptx ph locations", {
expect_equivalent(observed_xfrm, theorical_xfrm)
})


test_that("pptx ph_location_type", {
opts <- options(cli.num_colors = 1) # suppress colors to check error message
on.exit(options(opts))

x <- read_pptx()
x <- x |> add_slide("Two Content")

expect_no_error({
x |> ph_with("correct ph type id", ph_location_type("body", id = 1))
})

expect_error({
x |> ph_with("out of range type id", ph_location_type("body", id = 3)) # 3 does not exists => no error or warning
}, regexp = "`id` is out of range.", fixed = TRUE)

expect_error({
x |> ph_with("type okay but not available in layout", ph_location_type("tbl")) # tbl not on layout
}, regexp = "Found no placeholder of type", fixed = TRUE)

expect_error({
x |> ph_with("xxx is unknown type", ph_location_type("xxx"))
}, regexp = 'type "xxx" is unknown', fixed = TRUE)
})


test_that("pptx ph labels", {
doc <- read_pptx()
doc <- add_slide(doc, "Title and Content", "Office Theme")
Expand Down
Loading