R/ph_location.R

In officer: Manipulation of Microsoft Word and PowerPoint Documents

props_to_ph_location <- function(props) {
  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)
}


# id is deprecated and replaced by type_idx. Will be removed soon
get_ph_loc <- function(x, layout, master, type, type_idx = NULL, position_right, position_top,
                       id = NULL, ph_id = NULL) {
  props <- layout_properties(x, layout = layout, master = master)

  if (!is.null(ph_id)) {
    ids <- sort(stats::na.omit(as.numeric(props$id)))
    if (length(ids) <= 20) {
      .all_ids_switch <- c("x" = "Available ids:  {.val {ids}}.") # only if few ids
    } else {
      .all_ids_switch <- NULL
    }
    if (!ph_id %in% ids) {
      cli::cli_abort(
        c(
          "{.arg id} {.val {ph_id}} does not exist.",
          .all_ids_switch,
          "i" = cli::col_grey("see column {.val id} in {.code layout_properties(..., '{layout}', '{master}')}")
        ),
        call = NULL
      )
    }
    props <- props[props$id == ph_id, , drop = FALSE]
    return(props_to_ph_location(props))
  }

  types_on_layout <- unique(props$type)
  props <- props[props$type %in% type, , drop = FALSE]
  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)
  }

  # id and type_idx are both used for now. 'id' is deprecated. The following code block can be removed in the future.
  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
      )
    }
    # the ordering of 'type_idx' (top->bottom, left-righ) is different than for the 'id' arg (index
    # along the id colomn). Here, we restore the old ordering, to avoid a breaking change.
    props <- props[order(props$type, as.integer(props$id)), ] # set order for type idx. Removing the line would result in the default layout properties order, i.e., top->bottom left->right.
    props$.id <- stats::ave(props$type, props$master_name, props$name, props$type, FUN = seq_along)
    props <- props[props$.id == id, , drop = FALSE]
    return(props_to_ph_location(props))
  }

  if (!is.null(type_idx)) {
    if (!type_idx %in% props$type_idx) {
      cli::cli_abort(
        c(
          "{.arg type_idx} is out of range.",
          "x" = "Must be between {.val {1L}} and {.val {max(props$type_idx)}} for ph type {.val {type}}.",
          "i" = cli::col_grey("see {.code layout_properties(..., layout = '{layout}', master = '{master}')} for indexes of type '{type}'")
        ),
        call = NULL
      )
    }
    props <- props[props$type_idx == type_idx, , drop = FALSE]
    return(props_to_ph_location(props))
  }

  if (position_right) {
    props <- props[props$offx + 0.0001 > max(props$offx), ]
  } else {
    props <- props[props$offx - 0.0001 < min(props$offx), ]
  }
  if (position_top) {
    props <- props[props$offy - 0.0001 < min(props$offy), ]
  } else {
    props <- props[props$offy + 0.0001 > max(props$offy), ]
  }
  props_to_ph_location(props)
}


as_ph_location <- function(x, ...) {
  if (!is.data.frame(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"
  )
  if (!all(is.element(ref_names, names(x)))) {
    stop("missing column values:", paste0(setdiff(ref_names, names(x)), collapse = ","))
  }
  out <- x[ref_names]
  as.list(out)
}


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.
#' This function is to be used to add custom openxml code. A
#' list is returned, it contains informations width, height, left
#' and top positions and other informations necessary to add a
#' content on a slide.
#' @param x a location for a placeholder.
#' @param doc an rpptx object
#' @param ... unused arguments
#' @examples
#' doc <- read_pptx()
#' doc <- add_slide(doc,
#'   layout = "Title and Content",
#'   master = "Office Theme"
#' )
#' fortify_location(ph_location_fullsize(), doc)
#' @seealso [ph_location()], [ph_with()]
#' @family functions for officer extensions
#' @keywords internal
fortify_location <- function(x, doc, ...) {
  UseMethod("fortify_location")
}

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

#' @export
#' @title Location for a placeholder from scratch
#' @description The function will return a list that complies with
#' expected format for argument `location` of function [ph_with()].
#' @param left,top,width,height place holder coordinates
#' in inches.
#' @param newlabel a label for the placeholder. See section details.
#' @param bg background color
#' @param rotation rotation angle
#' @param ln a [sp_line()] object specifying the outline style.
#' @param geom shape geometry, see http://www.datypic.com/sc/ooxml/t-a_ST_ShapeType.html
#' @param ... unused arguments
#' @family functions for placeholder location
#' @details
#' The location of the bounding box associated to a placeholder
#' within a slide is specified with the left top coordinate,
#' the width and the height. These are defined in inches:
#'
#' \describe{
#'   \item{left}{left coordinate of the bounding box}
#'   \item{top}{top coordinate of the bounding box}
#'   \item{width}{width of the bounding box}
#'   \item{height}{height of the bounding box}
#' }
#'
#' In addition to these attributes, a label can be
#' associated with the shape. Shapes, text boxes, images and other objects
#' will be identified with that label in the *Selection Pane* of PowerPoint.
#' This label can then be reused by other functions such as `ph_location_label()`.
#' It can be set with argument `newlabel`.
#' @examples
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(doc, "Hello world",
#'   location = ph_location(width = 4, height = 3, newlabel = "hello")
#' )
#' print(doc, target = tempfile(fileext = ".pptx"))
#'
#' # Set geometry and outline
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' loc <- ph_location(
#'   left = 1, top = 1, width = 4, height = 3, bg = "steelblue",
#'   ln = sp_line(color = "red", lwd = 2.5),
#'   geom = "trapezoid"
#' )
#' doc <- ph_with(doc, "", loc = loc)
#' print(doc, target = tempfile(fileext = ".pptx"))
ph_location <- function(left = 1, top = 1, width = 4, height = 3,
                        newlabel = "", bg = NULL, rotation = NULL,
                        ln = NULL, geom = NULL, ...) {
  # remove name in case of named vector entry, e.g. ph_location(top = x["top])
  left <- unname(left)
  top <- unname(top)
  width <- unname(width)
  height <- unname(height)
  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_
  )
  class(x) <- c("location_manual", "location_str")
  x
}


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

#' @title Location for a placeholder based on a template
#' @description The function will return a list that complies with
#' expected format for argument `location` of function
#' [ph_with()]. A placeholder will be used as template
#' and its positions will be updated with values `left`, `top`, `width`, `height`.
#' @param left,top,width,height place holder coordinates
#' in inches.
#' @param newlabel a label for the placeholder. See section details.
#' @param type placeholder type to look for in the slide layout, one
#' of 'body', 'title', 'ctrTitle', 'subTitle', 'dt', 'ftr', 'sldNum'.
#' It will be used as a template placeholder.
#' @param id index of the placeholder template. If two body placeholder, there can be
#' two different index: 1 and 2 for the first and second body placeholders defined
#' in the layout.
#' @param ... unused arguments
#' @family functions for placeholder location
#' @inherit ph_location details
#' @examples
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(doc, "Title",
#'   location = ph_location_type(type = "title")
#' )
#' doc <- ph_with(doc, "Hello world",
#'   location = ph_location_template(top = 4, type = "title")
#' )
#' print(doc, target = tempfile(fileext = ".pptx"))
#' @export
ph_location_template <- function(left = 1, top = 1, width = 4, height = 3,
                                 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
  )

  class(x) <- c("location_template", "location_str")
  x
}
#' @export
fortify_location.location_template <- function(x, doc, ...) {
  slide <- doc$slide$get_slide(doc$cursor)
  if (!is.null(x$type)) {
    ph <- slide$get_xfrm(type = x$type, index = x$id)$ph
  } else {
    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
  )
  x$ph <- ph
  fortify_location.location_manual(x)
}


#' @export
#' @title Location of a placeholder based on a type
#' @description The function will use the type name of the placeholder (e.g. body, title),
#' the layout name and few other criterias to find the corresponding location.
#' @param type placeholder type to look for in the slide layout, one
#' of 'body', 'title', 'ctrTitle', 'subTitle', 'dt', 'ftr', 'sldNum'.
#' @param position_right the parameter is used when a selection with above
#' parameters does not provide a unique position (for example
#' layout 'Two Content' contains two element of type 'body').
#' If `TRUE`, the element the most on the right side will be selected,
#' otherwise the element the most on the left side will be selected.
#' @param position_top same than `position_right` but applied
#' to top versus bottom.
#' @param type_idx Type index of the placeholder. If there is more than one
#' placeholder of a type (e.g., `body`), the type index can be supplied to uniquely
#' identify a ph. The index is a running number starting at 1. It is assigned by
#' placeholder position  (top -> bottom, left -> right). See [plot_layout_properties()]
#' for details. If `idx` argument is used, `position_right` and `position_top`
#' are ignored.
#' @param id (**DEPRECATED, use `type_idx` instead**) Index of the placeholder.
#' If two body placeholder, there can be two different index: 1 and 2 for the
#' first and second body placeholders defined in the layout. If this argument
#' is used, `position_right` and `position_top` will be ignored.
#' @param newlabel a label to associate with the placeholder.
#' @param ... unused arguments
#' @family functions for placeholder location
#' @inherit ph_location details
#' @examples
#' # ph_location_type demo ----
#'
#' loc_title <- ph_location_type(type = "title")
#' loc_footer <- ph_location_type(type = "ftr")
#' loc_dt <- ph_location_type(type = "dt")
#' loc_slidenum <- ph_location_type(type = "sldNum")
#' loc_body <- ph_location_type(type = "body")
#'
#'
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(x = doc, "Un titre", location = loc_title)
#' doc <- ph_with(x = doc, "pied de page", location = loc_footer)
#' doc <- ph_with(x = doc, format(Sys.Date()), location = loc_dt)
#' doc <- ph_with(x = doc, "slide 1", location = loc_slidenum)
#' doc <- ph_with(x = doc, letters[1:10], location = loc_body)
#'
#' loc_subtitle <- ph_location_type(type = "subTitle")
#' loc_ctrtitle <- ph_location_type(type = "ctrTitle")
#' doc <- add_slide(doc, layout = "Title Slide")
#' doc <- ph_with(x = doc, "Un sous titre", location = loc_subtitle)
#' doc <- ph_with(x = doc, "Un titre", location = loc_ctrtitle)
#'
#' fileout <- tempfile(fileext = ".pptx")
#' print(doc, target = fileout)
#'
ph_location_type <- function(type = "body", type_idx = NULL, position_right = TRUE, position_top = TRUE,
                             newlabel = NULL, id = NULL, ...) {
  # the following two warnings can be deleted after the deprecated id arg is removed.
  if (!is.null(id) && !is.null(type_idx)) {
    cli::cli_warn("{.arg id} is ignored if {.arg type_idx} is provided ")
  }
  if (!is.null(id) && is.null(type_idx)) {
    cli::cli_warn(
      c(
        "!" = "The {.arg id} argument in {.fn ph_location_type} is deprecated as of {.pkg officer} 0.6.7.",
        "i" = "Please use the {.arg type_idx} argument instead.",
        "x" = cli::col_red("Caution: new index logic in {.arg type_idx} (see docs).")
      )
    )
  }

  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, type_idx = type_idx, 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, ...) {
  slide <- doc$slide$get_slide(doc$cursor)
  xfrm <- slide$get_xfrm()
  args <- list(...)

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

  # 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
  )
  if (!is.null(x$label)) {
    out$ph_label <- x$label
  }
  out
}


#' @export
#' @title Location of a named placeholder
#' @description The function will use the label of a placeholder
#' to find the corresponding location.
#' @param ph_label placeholder label of the used layout. It can be read in PowerPoint or
#' with function [layout_properties()] in column `ph_label`.
#' @param newlabel a label to associate with the placeholder.
#' @param ... unused arguments
#' @family functions for placeholder location
#' @inherit ph_location details
#' @examples
#' # ph_location_label demo ----
#'
#' doc <- read_pptx()
#' doc <- add_slide(doc, layout = "Title and Content")
#'
#' # all ph_label can be read here
#' layout_properties(doc, layout = "Title and Content")
#'
#' doc <- ph_with(doc, head(iris),
#'   location = ph_location_label(ph_label = "Content Placeholder 2")
#' )
#' doc <- ph_with(doc, format(Sys.Date()),
#'   location = ph_location_label(ph_label = "Date Placeholder 3")
#' )
#' doc <- ph_with(doc, "This is a title",
#'   location = ph_location_label(ph_label = "Title 1")
#' )
#'
#' print(doc, target = tempfile(fileext = ".pptx"))
ph_location_label <- function(ph_label, newlabel = NULL, ...) {
  x <- list(ph_label = unname(ph_label), label = unname(newlabel))
  class(x) <- c("location_label", "location_str")
  x
}


#' @export
fortify_location.location_label <- function(x, doc, ...) {
  slide <- doc$slide$get_slide(doc$cursor)
  xfrm <- slide$get_xfrm()

  layout <- unique(xfrm$name)
  master <- unique(xfrm$master_name)

  props <- layout_properties(doc, layout = layout, master = master)
  props <- props[props$ph_label %in% x$ph_label, , drop = FALSE]

  if (nrow(props) < 1) {
    stop("no selected row")
  }

  if (nrow(props) > 1) {
    stop(
      "Placeholder ", shQuote(x$ph_label),
      " in the slide layout is duplicated. It needs to be unique. Hint: layout_dedupe_ph_labels() helps handling duplicates."
    )
  }

  props <- props[, c("offx", "offy", "cx", "cy", "ph_label", "ph", "type", "rotation", "fld_id", "fld_type")]
  names(props) <- c("left", "top", "width", "height", "ph_label", "ph", "type", "rotation", "fld_id", "fld_type")
  row.names(props) <- NULL
  out <- as_ph_location(props)
  if (!is.null(x$label)) {
    out$ph_label <- x$label
  }
  out
}


#' @export
#' @title Location of a full size element
#' @description The function will return the location corresponding
#' to a full size display.
#' @param newlabel a label to associate with the placeholder.
#' @param ... unused arguments
#' @family functions for placeholder location
#' @examples
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(doc, "Hello world", location = ph_location_fullsize())
#' print(doc, target = tempfile(fileext = ".pptx"))
ph_location_fullsize <- function(newlabel = "", ...) {
  x <- list(label = newlabel)
  class(x) <- c("location_fullsize", "location_str")
  x
}

#' @export
fortify_location.location_fullsize <- function(x, doc, ...) {
  layout_data <- slide_size(doc)
  layout_data$left <- 0L
  layout_data$top <- 0L
  if (!is.null(x$label)) {
    layout_data$ph_label <- x$label
  }
  layout_data$ph <- NA_character_
  layout_data$type <- "body"
  layout_data$rotation <- 0L
  layout_data$fld_id <- NA_character_
  layout_data$fld_type <- NA_character_

  as_ph_location(as.data.frame(layout_data, stringsAsFactors = FALSE))
}

#' @export
#' @title Location of a left body element
#' @description The function will return the location corresponding
#' to a left bounding box. The function assume the layout 'Two Content'
#' is existing. This is an helper function, if you don't have a layout
#' named 'Two Content', use [ph_location_type()] and set arguments
#' to your specific needs.
#' @param newlabel a label to associate with the placeholder.
#' @param ... unused arguments
#' @family functions for placeholder location
#' @examples
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(doc, "Hello left", location = ph_location_left())
#' doc <- ph_with(doc, "Hello right", location = ph_location_right())
#' print(doc, target = tempfile(fileext = ".pptx"))
ph_location_left <- function(newlabel = NULL, ...) {
  x <- list(label = newlabel)
  class(x) <- c("location_left", "location_str")
  x
}

#' @export
fortify_location.location_left <- function(x, doc, ...) {
  slide <- doc$slide$get_slide(doc$cursor)
  xfrm <- slide$get_xfrm()

  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
  )
  if (!is.null(x$label)) {
    out$ph_label <- x$label
  }
  out
}


#' @export
#' @title Location of a right body element
#' @description The function will return the location corresponding
#' to a right bounding box. The function assume the layout 'Two Content'
#' is existing. This is an helper function, if you don't have a layout
#' named 'Two Content', use [ph_location_type()] and set arguments
#' to your specific needs.
#' @param newlabel a label to associate with the placeholder.
#' @param ... unused arguments
#' @family functions for placeholder location
#' @examples
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Title and Content")
#' doc <- ph_with(doc, "Hello left", location = ph_location_left())
#' doc <- ph_with(doc, "Hello right", location = ph_location_right())
#' print(doc, target = tempfile(fileext = ".pptx"))
ph_location_right <- function(newlabel = NULL, ...) {
  x <- list(label = newlabel)
  class(x) <- c("location_right", "location_str")
  x
}


#' @export
fortify_location.location_right <- function(x, doc, ...) {
  slide <- doc$slide$get_slide(doc$cursor)
  xfrm <- slide$get_xfrm()

  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
  )
  if (!is.null(x$label)) {
    out$ph_label <- x$label
  }
  out
}


#' @export
#' @title Location of a placeholder based on its id
#' @description Each placeholder has an id (a low integer value). The ids are unique across a single
#' layout. The function uses the placeholder's id to reference it. Different from a ph label,
#' the id is auto-assigned by PowerPoint and cannot be modified by the user.
#' Use [layout_properties()] (column `id`) and [plot_layout_properties()] (upper right
#' corner, in green) to find a placeholder's id.
#'
#' @param id placeholder id.
#' @param newlabel a new label to associate with the placeholder.
#' @param ... not used.
#' @family functions for placeholder location
#' @inherit ph_location details
#' @examples
#' doc <- read_pptx()
#' doc <- add_slide(doc, "Comparison")
#' plot_layout_properties(doc, "Comparison")
#'
#' doc <- ph_with(doc, "The Title", location = ph_location_id(id = 2)) # title
#' doc <- ph_with(doc, "Left Header", location = ph_location_id(id = 3)) # left header
#' doc <- ph_with(doc, "Left Content", location = ph_location_id(id = 4)) # left content
#' doc <- ph_with(doc, "The Footer", location = ph_location_id(id = 8)) # footer
#'
#' file <- tempfile(fileext = ".pptx")
#' print(doc, file)
#' \dontrun{
#' file.show(file) # may not work on your system
#' }
ph_location_id <- function(id, newlabel = NULL, ...) {
  ph_id <- id # for disambiguation, store initial value

  if (length(ph_id) > 1) {
    cli::cli_abort(
      c("{.arg id} must be {cli::style_underline('one')} number",
        "x" = "Found more than one entry: {.val {ph_id}}"
      )
    )
  }
  if (is.null(ph_id) || is.na(ph_id) || length(ph_id) == 0) {
    cli::cli_abort("{.arg id} must be a positive number")
  }
  if (!is.integer(ph_id)) {
    ph_id <- suppressWarnings(as.integer(ph_id))
    if (is.na(ph_id)) {
      cli::cli_abort(
        c("Cannot convert {.val {id}} to integer",
          "x" = "{.arg id} must be a number, you provided class {.cls {class(id)[1]}}"
        )
      )
    }
  }
  if (ph_id < 1) {
    cli::cli_abort(
      c("{.arg id} must be a {cli::style_underline('positive')} number",
        "x" = "Found {.val {ph_id}}"
      )
    )
  }
  x <- list(
    type = NULL, type_idx = NULL, position_right = NULL, position_right = NULL,
    position_top = NULL, id = NULL, ph_id = ph_id, label = newlabel
  )
  class(x) <- c("location_id", "location_num")
  x
}


#' @export
fortify_location.location_id <- function(x, doc, ...) {
  slide <- doc$slide$get_slide(doc$cursor)
  xfrm <- slide$get_xfrm()
  args <- list(...)

  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, ph_id = x$ph_id)
  if (!is.null(x$label)) {
    out$ph_label <- x$label
  }
  out
}

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

#' @export
#' @keywords internal
#' @title Resolve short form location
#' @description
#' Convert short form location format, a numeric or a string (e.g. `"body [1]"`),
#' into its corresponding location object. Under the hood, we parse the short form location and
#' call the corresponding function from the `ph_location_*` family. Note that short forms may not
#' cover all function from the `ph_location_*` and offer less customization.
#'
#' @section Short forms:
#' The following location short forms are implemented. The corresponding call of the function from the
#' `ph_location_*` family is displayed on the right.
#'
#' | **Short form** | **Description**                                             | **Location function**           |
#' |----------------|-------------------------------------------------------------|---------------------------------|
#' | `"left"`       | Keyword string                                              | `ph_location_left()`            |
#' | `"right"`      | Keyword string                                              | `ph_location_right()`           |
#' | `"fullsize"`   | Keyword string                                              | `ph_location_fullsize()`        |
#' | `"body [1]"`   | String: type + index in brackets (`1` if omitted)           | `ph_location_type("body", 1)`   |
#' | `"my_label"`   | Any string not matching a keyword or type                   | `ph_location_label("my_label")` |
#' | `2`            | Length 1 integer                                            | `ph_location_id(2)`             |
#' | `c(0,0,4,5)`   | Length 4 numeric, optionally named, `c(top=0, left=0, ...)` | `ph_location(0, 0, 4, 5)`       |
#'
#' @examples
#' resolve_location("left")
#' resolve_location("right")
#' resolve_location("fullsize")
#' resolve_location("body")
#' resolve_location("body [1]")
#' resolve_location("<some label>")
#' resolve_location(2)
#' resolve_location(c(0, 0, 4, 5))
#'
resolve_location <- function(x) {
  if (is_ph_location(x)) {
    return(x)
  }
  if (is.null(x) || (is.vector(x) && is.na(x)[1])) {
    raise_location_value_error(x)
  }
  if (is.numeric(x)) {
    loc <- resolve_location_from_numeric(x)
  } else if (is.character(x)) {
    loc <- resolve_location_from_character(x)
  } else {
    cli::cli_abort(
      call = NULL,
      "Cannot resolve class {.cls {class(x)[1]}} into a location",
      "x" = "Must be a character or numeric vector."
    )
  }
  loc
}


raise_location_value_error <- function(x) {
  cli::cli_abort(
    call = NULL,
    c("Incorrect value for {.arg location}",
      "x" = "Must be a vector (character or numeric) or a ph_location object"
    )
  )
}


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 a length 1 numeric, {.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) {
  if (!is_named(x)) {
    cli::cli_abort(
      c("Some vector elements have no names",
        "x" = "{.arg x} must be a named vector"
      )
    )
  }
  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")
      ),
      call = NULL
    )
  }
  # 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")
      ),
      call = NULL
    )
  }
  setNames(x, nms_new)
}


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


resolve_location_from_character <- function(x) {
  if (is.character(x) && length(x) > 1) {
    cli::cli_abort(
      c("{.arg location} has incorrect length.",
        "x" = "Character vector passed to {.arg location} must have length 1"
      ),
      call = NULL
    )
  }
  # cases:
  # - 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)
  }
  location
}

# 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*(\\[\\s*\\d+\\s*\\])?$"

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)
}