experimental support for package logos in HTML help

git-svn-id: https://svn.r-project.org/R/trunk@88929 00db46b3-68df-0310-9c12-caf00c1e9a41

Author: deepayan

src/library/tools/R/Rd2HTML.R

@@ -361,6 +361,34 @@ createRedirects <- function(file, Rdobj)
 }
 
 
+
+### Helper function to find a suitable package logo (logo.png, logo.svg); otherwise return R logo
+
+## For an installed package, we can use system.file(). This is what is
+## needed for dynamic help. To interpret 'package' as a source
+## directory, specify 'dir = TRUE'
+
+
+staticLogoPath <- function(package, relative = FALSE, Rhome = "../../..", dir = FALSE) {
+    if (dir) {
+        file <- file.path(package, "man", "figures", "logo.png")
+        if (!file.exists(file)) file <- file.path(package, "man", "figures", "logo.svg")
+        if (!file.exists(file)) file <- R.home("doc/html/Rlogo.svg")
+    } else {
+        file <- system.file("help", "figures", "logo.png", package = package)
+        if (!nzchar(file)) file <- system.file("help", "figures", "logo.svg", package = package)
+        if (!nzchar(file)) file <- R.home("doc/html/Rlogo.svg")
+    }
+    if (relative) {
+        file <- if (endsWith(file, "/logo.png")) "figures/logo.png"
+                else if (endsWith(file, "/logo.svg")) "figures/logo.svg"
+                else file.path(Rhome, "doc/html/Rlogo.svg")
+    }
+    file
+}
+
+
+
 ## This gets used two ways:
 
 ## 1) With dynamic = TRUE from tools:::httpd()
@@ -1198,6 +1226,8 @@ Rd2HTML <-
 
         of0('<nav class="topic" aria-label="Section Navigation">\n',
             '<div class="dropdown-menu">\n',
+            if (dynamic) '<img class="toplogo" src="../logo" alt="[logo]">'
+            else sprintf('<img class="toplogo" src="%s" alt="[logo]">', staticLogoPath(package, relative = TRUE)),
             '<h1>Contents</h1>\n',
             '<ul class="menu">\n')
 
@@ -1294,10 +1324,11 @@ Rd2HTML <-
         ## Create HTML header and footer
         if (standalone) {
             hfcomps <- # should we be able to specify static URLs here?
-                HTMLcomponents(title = headtitle, logo = FALSE,
+                HTMLcomponents(title = "", logo = FALSE,
                                up = NULL,
                                top = NULL,
                                css = stylesheet,
+                               headerTitle = headtitle,
                                outputEncoding = outputEncoding,
                                dynamic = dynamic, prism = enhancedHTML,
                                doTexMath = doTexMath, texmath = texmath,

src/library/tools/R/dynamicHelp.R

@@ -392,6 +392,7 @@ httpd <- function(path, query, ...)
     ExampleRegexp <- "^/library/([^/]*)/Example/([^/]*)$"
     newsRegexp <- "^/library/([^/]*)/NEWS([.](Rd|md))?$"
     figureRegexp <- "^/library/([^/]*)/(help|html)/figures/([^/]*)$"
+    logoRegexp <- "^/library/([^/]*)/logo$"
     sessionRegexp <- "^/session/"
     packageIndexRegexp <- "^/library/([^/]*)$"
     packageLicenseFileRegexp <- "^/library/([^/]*)/(LICEN[SC]E$)"
@@ -658,7 +659,11 @@ httpd <- function(path, query, ...)
         fig <- sub(figureRegexp, "\\3", path)
         file <- system.file("help", "figures", fig, package=pkg)
         return( list(file=file, "content-type" = mime_type(fig)) )
-    } else if (grepl(sessionRegexp, path)) {
+    } else if (grepl(logoRegexp, path)) {
+        pkg <- sub(logoRegexp, "\\1", path)
+        file <- staticLogoPath(pkg)
+        return( list(file=file, "content-type" = mime_type(basename(file))) )
+     } else if (grepl(sessionRegexp, path)) {
         tail <- sub(sessionRegexp, "", path)
     	file <- file.path(tempdir(), tail)
     	return( list(file=file, "content-type" = mime_type(tail)) )

src/library/tools/R/install.R

@@ -2857,7 +2857,9 @@ if(FALSE) {
 
     html_header <- function(pkg, title, version, encoding, conn)
     {
-        cat(paste(HTMLheader(title, Rhome="../../..",
+        cat(paste(HTMLheader(title,
+                             logo = staticLogoPath(dir, relative = TRUE, Rhome = "../../..", dir = TRUE),
+                             Rhome="../../..",
                              up="../../../doc/html/packages.html",
                              css = "R.css"),
                   collapse = "\n"),

src/library/tools/R/pkg2HTML.R

@@ -48,6 +48,7 @@
     db <- 
         if (!missing(package) && isTRUE(isPkgTarball(package)))
         {
+            src.type <- "tarball"
             ## If URL, download first
             if (isURL(package)) {
                 destdir <- tempfile("dir")
@@ -71,7 +72,7 @@
             Rd_db(dir = pkgdir, stages = stages)
         }
         else {
-            ## FIXME: needs cleanup
+            src.type <- if (is.null(dir)) "installed" else "source"
             pkgdir <- if (is.null(dir)) find.package(package, lib.loc) else dir
             if (is.null(dir)) Rd_db(package, , lib.loc, stages = stages)
             else Rd_db(, dir, lib.loc, stages = stages)
@@ -96,6 +97,7 @@
         list(outlines = outlines, info = attr(h, "info"))
     }
     structure(lapply(db, rd2lines, standalone = FALSE, ...),
+              pkgdir = pkgdir, src.type = src.type,
               descfile = file.path(pkgdir, "DESCRIPTION"))
 
 }
@@ -121,6 +123,8 @@ pkg2HTML <- function(package, dir = NULL, lib.loc = NULL,
                                          Rhtml = Rhtml, hooks = hooks,
                                          texmath = "katex", prism = prism, ...)
     descfile <- attr(hcontent, "descfile")
+    src.type <- attr(hcontent, "src.type")
+    pkgdir <- attr(hcontent, "pkgdir")
     descmeta <- .read_description(descfile)
     pkgname <- descmeta["Package"]
     if (is.null(out)) {
@@ -182,6 +186,9 @@ pkg2HTML <- function(package, dir = NULL, lib.loc = NULL,
     ##                   pkgname))
     writeHTML('<nav class="package" aria-label="Topic Navigation">',
               '<div class="dropdown-menu">',
+              sprintf('<img class="toplogo" src="%s" alt="[logo]">',
+                      if (src.type == "installed") staticLogoPath(pkgname, relative = FALSE)
+                      else staticLogoPath(pkgdir, relative = FALSE, dir = TRUE)),
               sprintf('<h1>Package {%s}</h1>', pkgname),
               '<h2>Contents</h2>',
               '<ul class="menu">',

src/library/tools/R/toHTML.R

@@ -24,10 +24,11 @@ function(title="R", logo=TRUE,
           paste0('<link rel="stylesheet" type="text/css" href="', css, '">'),
           '</head><body><div class="container">',
           paste('<h1>', title))
-    if (logo)
+    if (!isFALSE(logo))
     	result <- c(result,
                     paste0('<img class="toplogo" src="',
-                           file.path(Rhome, 'doc/html/Rlogo.svg'),
+                           if (isTRUE(logo)) file.path(Rhome, 'doc/html/Rlogo.svg')
+                           else logo,
                            '" alt="[R logo]">'))
     result <- c(result, '</h1>', '<hr>')
     if (!is.null(up) || !is.null(top)) {
@@ -525,12 +526,13 @@ HTMLcomponents <- function(title = "R", logo = FALSE,
 
     ## Optional part of header (title + logo, up, top)
 
-    if (!nzchar(title)) {
+    if (nzchar(title)) {
         addh('<h1>', title)
-        if (logo)
+        if (!isFALSE(logo))
             addh(paste0('<img class="toplogo" src="',
-                        file.path(Rhome, 'doc/html/Rlogo.svg'),
-                        '" alt="[R logo]">'))
+                        if (isTRUE(logo)) file.path(Rhome, 'doc/html/Rlogo.svg')
+                        else logo,
+                        '" alt="[logo]">'))
         addh('</h1>', '<hr>')
     }
     if (!is.null(up) || !is.null(top)) {

src/library/tools/man/HTMLheader.Rd

@@ -23,7 +23,8 @@ The title to display and use in the HTML headers.  Should have had any
 HTML escaping already done.
 }
   \item{logo}{
-Whether to display the \R{} logo after the title.
+Logical indicating whether to display the \R{} logo after the title, or
+a character string giving the path of the logo to be displayed.
 }
   \item{up}{
 Which page (if any) to link to on the \dQuote{up} button.