rkwarddev: A Collection of Tools for RKWard Plugin Development

Documented in rk.XML.pluginmap

# Copyright 2010-2014 Meik Michalke <meik.michalke@hhu.de>
#
# This file is part of the R package rkwarddev.
#
# rkwarddev is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# rkwarddev is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with rkwarddev.  If not, see <http://www.gnu.org/licenses/>.


#' Write a pluginmap file for RKWard
#'
#' @param name Character string, name of the plugin.
#' @param about An object of class \code{XiMpLe.node} to be pasted as the \code{<about>} section,
#'    See \code{link[XiMpLe:rk.XML.about]{rk.XML.about}} for details. Skipped if \code{NULL}.
#' @param components Either an object of class \code{XiMpLe.node} to be pasted as the \code{<components>} section (see
#'    \code{\link[rkwarddev:rk.XML.components]{rk.XML.components}} for details). Or a character vector with at least
#'    one plugin component file name, relative path from the pluginmap file and ending with ".xml". Can be set to \code{NULL} if
#'    \code{require} is used accordingly.
#' @param hierarchy Either an object of class \code{XiMpLe.node} to be pasted as the \code{<hierarchy>} section (see
#'    \code{\link[rkwarddev:rk.XML.hierarchy]{rk.XML.hierarchy}} for details). Or a character vector with instructions
#'    where to place the plugin in the menu hierarchy, one list or string for each included component. Valid single values are
#'    \code{"file"}, \code{"edit"}, \code{"view"}, \code{"workspace"}, \code{"run"}, \code{"data"},
#'    \code{"analysis"}, \code{"plots"}, \code{"distributions"}, \code{"windows"}, \code{"settings"} and \code{"help"},
#'    anything else will place it in a "test" menu. If \code{hierarchy} is a list, each entry represents the label of a menu level.
#'    Can be set to \code{NULL} if \code{require} is used accordingly.
#' @param require Either a (list of) objects of class \code{XiMpLe.node} to be pasted as a \code{<require>} section (see
#'    \code{\link[rkwarddev:rk.XML.require]{rk.XML.require}} for details). Or a character vector with at least
#'    one .pluginmap filename to be included in this one.
#' @param x11.context An object of class \code{XiMpLe.node} to be pasted as a \code{<context id="x11">} section, see
#'    \code{\link[rkwarddev:rk.XML.context]{rk.XML.context}} for details.
#' @param import.context An object of class \code{XiMpLe.node} to be pasted as the \code{<context id="import">} section, see
#'    \code{\link[rkwarddev:rk.XML.context]{rk.XML.context}} for details.
#' @param clean.name Logical, if \code{TRUE}, all non-alphanumeric characters except the underscore (\code{"_"}) will be removed from \code{name}.
#' @param hints Logical, if \code{TRUE} and you leave out optional entries (like \code{about=NULL}), dummy sections will be added as comments.
#' @param gen.info Logical, if \code{TRUE} a comment note will be written into the document,
#'    that it was generated by \code{rkwarddev} and changes should be done to the script.
#'    You can also provide a character string naming the very rkwarddev script file that generates this pluginmap,
#'    which will then also be added to the comment.
#' @param dependencies An object of class \code{XiMpLe.node} to be pasted as the \code{<dependencies>} section,
#'    See \code{\link[rkwarddev:rk.XML.dependencies]{rk.XML.dependencies}} for details. Skipped if \code{NULL}.
#' @param namespace Character string, the namespace attribute of the \code{<document>} node, defaults to the plugin name (which you probably shouldn't touch...).
#'    RKWard's internal plugins should use the namespace \code{rkward}. This is taken care of by \code{\link[rkwarddev:rk.plugin.skeleton]{rk.plugin.skeleton}}
#'    if you set \code{internal=TRUE}.
#' @param priority Character string, the priority attribute of the \code{<document>} node. Must be either "hidden", "low", "medium", or "high",
#'    defaults to "medium".
#' @param id.name Character string, a unique ID for this plugin element. If \code{"auto"}, an ID will be generated automatically from \code{name}.
#' @param require.defaults Logical, if \code{TRUE}, \code{<require map="rkward::menu" />} and \code{<require  map="rkward::embedded" />} will be added
#'    by default, which ensures that the menu structure and embeddable plugins are loaded. It shouldn't hurt to set this.
#' @seealso \href{help:rkwardplugins}{Introduction to Writing Plugins for RKWard}
#' @return An object of class \code{XiMpLe.node}.
#' @export

rk.XML.pluginmap <- function(name, about=NULL, components, hierarchy="test",
  require=NULL, x11.context=NULL, import.context=NULL, clean.name=TRUE, hints=FALSE, gen.info=TRUE,
  dependencies=NULL, namespace=name, priority="medium", id.name="auto", require.defaults=TRUE){
  name.orig <- name
  if(isTRUE(clean.name)){
    # to besure, remove all non-character symbols from name
    name <- clean.name(name)
  } else {}

  # one of components or require *must* be used
  if(is.null(components) && is.null(require)){
    stop(simpleError("'components' or 'require' must be specified!"))
  } else {}

  # .pluginmap has these children in <document>:
  # - dependencies (optional)
  # - about (optional)
  # - require (optional, multiple)
  # - components (once)
  #   - component
  #     - attribute
  # - hierarchy (once)
  #   - menu
  #     - entry
  # - context (optional, "x11")
  #   - menu
  #     - entry
  # - context (optional, "import")
  #   - menu
  #     - entry

  all.children <- list()

  if(isTRUE(gen.info)){
    all.children[[length(all.children)+1]] <- generator.info()
  } else if(is.character(gen.info)){
    all.children[[length(all.children)+1]] <- generator.info(script=gen.info)
  } else {}

  # check about and dependencies
  # result is a named list with "about" and "dependencies"
  about.dep.list <- dependenciesCompatWrapper(dependencies=dependencies, about=about, hints=hints)
  dependencies <- about.dep.list[["dependencies"]]
  about <- about.dep.list[["about"]]

  ## dependencies section
  if(!is.null(dependencies)){
    all.children[[length(all.children)+1]] <- dependencies
  } else {}

  ## about section
  if(!is.null(about)){
    all.children[[length(all.children)+1]] <- about
  } else {}

  ## require section
  if(isTRUE(require.defaults)){
    if(is.null(require)){
      
    } else {
    }
  } else {}
  if(!is.null(require)){
    # check if this is *really* require nodes
    for(this.child in child.list(require)){
        if(is.XiMpLe.node(this.child)){
          valid.parent("require", node=this.child, see="rk.XML.require")
          all.children[[length(all.children)+1]] <- this.child
        } else {
          if(grepl(".pluginmap", this.child)){
            all.children[[length(all.children)+1]] <- rk.XML.require(file=this.child)
          } else {
            stop(simpleError("Only .pluginmap files are valid for require nodes!"))
          }
        }
      }
  } else {
    if(!isTRUE(require.defaults) & isTRUE(hints)){
      require.XML <- XMLNode("!--", rk.XML.require("path/file.pluginmap"))
      all.children[[length(all.children)+1]] <- require.XML
    } else {}
  }
  # check defaults
  if(isTRUE(require.defaults)){
    all.children[[length(all.children)+1]] <- rk.XML.require(map="rkward::menu")
    all.children[[length(all.children)+1]] <- rk.XML.require(map="rkward::embedded")
  } else {}

  ## components section
  if(!is.null(components)){
    if(is.XiMpLe.node(components)){
      # check if this is *really* a components section, otherwise quit and go dancing
      valid.parent("components", node=components, see="rk.XML.components")
      all.children[[length(all.children)+1]] <- components
      # get the IDs for hierarchy section
      component.IDs <- sapply(slot(components, "children"), function(this.comp){
          slot(this.comp, "attributes")$id
        })
    } else {
        components.XML.list <- list()
        num.compos <- length(components)
        compo.names <- names(components)
        for (this.comp.num in 1:num.compos){
          this.comp <- components[this.comp.num]
          if(num.compos > 1) {
            # let's see if we have entry names
            if(length(compo.names) == length(components)){
              xml.basename <- compo.names[this.comp.num]
            } else {
              # remove any directory names and .EXT endings
              xml.basename <- gsub("(.*/)?([[:alnum:]_]*).+(.*)?", "\\2", this.comp, perl=TRUE)
            }
          } else {
            xml.basename <- name.orig
          }
          names(this.comp) <- NULL
          components.XML.list[[length(components.XML.list) + 1]] <- rk.XML.component(
            label=xml.basename,
            file=this.comp,
            # if this ID get's a change, also change it in rk.plugin.skeleton(show=TRUE)!
            id.name=auto.ids(paste0(name, xml.basename), prefix=ID.prefix("component"), chars=25))
          }
      components.XML <- rk.XML.components(components.XML.list)

      all.children[[length(all.children)+1]] <- components.XML
      # get the IDs for hierarchy section
      component.IDs <- sapply(slot(components.XML, "children"), function(this.comp){
          slot(this.comp, "attributes")$id
        })
    }
  } else {}

  ## hierachy section
  if(is.XiMpLe.node(hierarchy)){
    # check if this is *really* a hierarchy section, otherwise quit and go dancing
    valid.parent("hierarchy", node=hierarchy, see="rk.XML.hierarchy")
    all.children[[length(all.children)+1]] <- hierarchy
  } else {
    # if require loads another pluginmap, we might not need a hierarchy at all
    if(is.null(hierarchy)){
      if(is.null(require)){
        stop(simpleError("if 'hierarchy' is NULL, 'require' must be specified!"))
      } else {}
    } else {
      # correct for cases with one component and a list
      if(length(component.IDs) == 1 & is.list(hierarchy)){
        if(!is.list(hierarchy[[1]]))
        hierarchy <- list(hierarchy)
      } else {}
      # check if the numbers fit
      if(length(hierarchy) != length(component.IDs)){
        stop(simpleError("Length of 'hierarchy' and number of components must be the same!"))
      } else {}
      # predefined menu points
      main.menu <- c(file="File", edit="Edit", view="View", workspace="Workspace", run="Run",
        data="Data", analysis="Analysis", plots="Plots", distributions="Distributions",
        windows="Windows", settings="Settings", help="Help")

      hier.comp.XML <- sapply(1:length(hierarchy), function(this.dial){
        this.comp <- component.IDs[this.dial]
        if(is.list(hierarchy)){
          this.hier <- hierarchy[[this.dial]]
        } else {
          this.hier <- hierarchy[this.dial]
        }

        # hierachy can either be a list with menu paths, or predefined
        if(is.list(this.hier)){
          # check if we need to generate a hierarchy tree
          if(length(this.hier) > 1){
            new.hierarchy <- this.hier[2:length(this.hier)]
            new.hierarchy[[length(new.hierarchy) + 1]] <- this.comp
          } else {
            new.hierarchy <- rk.XML.entry(this.comp)
          }
          if(this.hier[[1]] %in% names(main.menu)){
            id.names <- sapply(this.hier, function(hier.id){
                return(clean.name(hier.id))
              })

            hier.XML <- rk.XML.menu(
              label=unlist(main.menu[[this.hier[[1]]]]),
              new.hierarchy,
              id.name=id.names)
          } else {
            hier.XML <- rk.XML.menu(
              label=this.hier[[1]],
              new.hierarchy)
          }
        } else {
          entry.XML <- rk.XML.menu(
            label=name.orig,
            rk.XML.entry(component=this.comp),
            id.name=auto.ids(paste0(name, this.comp), prefix=ID.prefix("menu"), chars=12))

          if(this.hier %in% names(main.menu)){
            hier.XML <- rk.XML.menu(
              label=main.menu[[this.hier]],
              entry.XML,
              id.name=this.hier)
          } else {
            hier.XML <- rk.XML.menu(
              label="Test",
              entry.XML,
              id.name="test")
          }
        }
        return(hier.XML)
      })
      all.children[[length(all.children)+1]] <- rk.XML.hierarchy(hier.comp.XML)
    }
  }

  ## context sections
  if(!is.null(x11.context)){
    # check if this is *really* a context node for x11
    if(is.XiMpLe.node(x11.context)){
      node.name <- slot(x11.context, "name")
      ctxt.name <- slot(x11.context, "attributes")$id
    } else {
      node.name <- ctxt.name <- "buhahahahaa"
    }
    if(!identical(node.name, "context") | !identical(ctxt.name, "x11")){
      stop(simpleError("I don't know what this is, but 'x11.context' is not a context node for x11!"))
    } else {
      all.children[[length(all.children)+1]] <- x11.context
    }
  } else {
    if(isTRUE(hints)){
      context.x11.XML <- XMLNode("!--", rk.XML.context(id="x11"))
      all.children[[length(all.children)+1]] <- context.x11.XML
    } else {}
  }
  # import
  if(!is.null(import.context)){
    # check if this is *really* a context node for import
    if(is.XiMpLe.node(import.context)){
      node.name <- slot(import.context, "name")
      ctxt.name <- slot(import.context, "attributes")$id
    } else {
      node.name <- ctxt.name <- "buhahahahaa"
    }
    if(!identical(node.name, "context") | !identical(ctxt.name, "import")){
      stop(simpleError("I don't know what this is, but 'import.context' is not a context node for import!"))
    } else {
      all.children[[length(all.children)+1]] <- import.context
    }
  } else {
    if(isTRUE(hints)){
      context.import.XML <- XMLNode("!--", rk.XML.context(id="import"))
      all.children[[length(all.children)+1]] <- context.import.XML
    } else {}
  }

  if(identical(id.name, "auto") | is.null(id.name)){
    # clean the ID of dots and append "_rkward"
    doc.ID.name <- paste0(gsub("[.]*", "", name), "_rkward")
  } else {
    doc.ID.name <- id.name
  }
  # check for empty "namespace" value
  if(is.null(namespace)){
    namespace <- "rkward"
  } else {}
  # check for valid values of "priority"
  if(!priority %in% c("hidden", "low", "medium", "high")){
    stop(simpleError("'priority' must be one of 'hidden', 'low', 'medium' or 'high'!"))
  } else {}

  all.attrs <- list(base_prefix="", namespace=namespace, id=doc.ID.name, po_id=doc.ID.name, priority=priority)
  top.doc <- XMLNode("document", attrs=all.attrs, .children=all.children)

  pluginmap <- XMLTree(
    dtd=list(doctype="rkpluginmap"),
    .children=child.list(top.doc)
  )

  return(pluginmap)
}