src/library/utils/R/linkhtml.R

#  File src/library/utils/R/linkhtml.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2015 The R Core Team
#
#  This program 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 2 of the License, or
#  (at your option) any later version.
#
#  This program 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.
#
#  A copy of the GNU General Public License is available at
#  https://www.R-project.org/Licenses/


make.packages.html <-
    function(lib.loc = .libPaths(), temp = FALSE, verbose = TRUE,
             docdir = R.home("doc"))
{
    add_lib_index <- function(libs)
    {
        cat('<div align="left">\n<ul>\n', file = out)
        for (i in seq_along(libs)) {
            nm <- libs[i]
            if (nm == .Library) {
                cat('<li>Contents of the <a href="#lib-', i, '">',
                    'standard</a> library</li>\n', sep = "", file = out)
            } else {
                cat('<li>Contents of <a href="#lib-', i, '">', nm,
                    '</a></li>\n', sep = "", file = out)
            }
        }
        cat("</ul>\n</div>\n", file = out)
    }

    WINDOWS <- .Platform$OS.type == "windows"
    f.tg <- if (temp) {
        dir.create(file.path(tempdir(), ".R/doc/html"), recursive = TRUE,
                   showWarnings = FALSE)
        file.path(tempdir(), ".R/doc/html/packages.html")
    } else file.path(docdir, "html", "packages.html")
    op <- file.path(tempdir(), ".R/doc/html/libPaths.rds")
    if (temp && file.exists(f.tg) && file.exists(op)) {
        ## check if we can avoid remaking it.
        if(identical(lib.loc, readRDS(op))) {
            dates <- file.mtime(c(f.tg, lib.loc))
            if(which.max(dates) == 1L) return(TRUE)
        }
    }
    if (!file.create(f.tg)) {
        warning("cannot update HTML package index")
        return(FALSE)
    }
    if (verbose) {
        message("Making 'packages.html' ...", appendLF = FALSE, domain = NA)
        flush.console()
    }
    file.append(f.tg,
                file.path(R.home("doc"), "html", "packages-head-utf8.html"))
    out <- file(f.tg, open = "a")
    on.exit(close(out))
    if(WINDOWS) {
        rh <- chartr("\\", "/", R.home())
        drive <- substring(rh, 1L, 2L)
    }
    ## find out how many
    pkgs <- vector("list", length(lib.loc))
    names(pkgs) <- lib.loc
    for (lib in lib.loc) {
        pg <- .packages(all.available = TRUE, lib.loc = lib)
        pkgs[[lib]] <- pg[order(toupper(pg), pg)]
    }
    if (WINDOWS) {
        tot <- sum(lengths(pkgs))
        if(verbose) {
            pb <- winProgressBar("R: creating packages.html", max = tot)
            on.exit(close(pb), add = TRUE)
        }
        npkgs <- 0L
    }
    ## If there is more than one lib, have an index at the top and bottom
    if (length(lib.loc) > 1L) add_lib_index(lib.loc)
    for (ii in seq_along(lib.loc)) {
        lib <- lib.loc[ii]
        libname <-
            if (identical(lib, .Library)) "the standard library" else if (WINDOWS) chartr("/", "\\", lib) else lib
        cat("<p><h3 id=\"lib-",ii,"\">Packages in ", libname, "</h3>\n", sep = "", file = out)
        lib0 <- "../../library"
        if (!temp) {
            if (WINDOWS) {
                ## use relative indexing for .Library
                ## perhaps other site libraries
                if (is.na(pmatch(rh, lib))) {
                    lib0 <- if(substring(lib, 2L, 2L) != ":")
                        paste0(drive, lib) else lib
                    lib0 <- paste0("file:///", URLencode(lib0))
                }
            } else {
                if (lib != .Library)
                    lib0 <- paste0("file:///", URLencode(lib))
            }
        }
        pg <- pkgs[[lib]]
        use_alpha <- (length(pg) > 100)
        first <- toupper(substr(pg, 1, 1))
        nm <- sort(names(table(first)))
        if(use_alpha) {
            writeLines("<p align=\"center\">", out)
            writeLines(paste0("<a href=\"#pkgs-", nm, "\">", nm, "</a>"), out)
            writeLines("</p>\n", out)
        }
        cat('<p><table width="100%" summary="R Package list">\n', file = out)
        for (a in nm) {
            if(use_alpha)
                cat("<tr id=\"pkgs-", a, "\"> <td></td>\n", sep = "", file = out)
            for (i in pg[first == a]) {
                title <- packageDescription(i, lib.loc = lib, fields = "Title",
                                            encoding = "UTF-8")
                if (is.na(title)) title <- "-- Title is missing --"
                cat('<tr align="left" valign="top" id="lib-', i, '">\n',
                    '<td width="25%"><a href="', lib0, '/', i,
                    '/html/00Index.html">', i, "</a></td><td>", title,
                    "</td></tr>\n", file = out, sep = "")
                if (WINDOWS) {
                    npkgs <- npkgs + 1L
                    if(verbose) setWinProgressBar(pb, npkgs)
                }
            }
        }
        cat("</table>\n\n", file=out)
    }
    if (length(lib.loc) > 1L) add_lib_index(lib.loc)
    cat("</body></html>\n", file=out)
    if (verbose) { message(" ", "done"); flush.console() }
    if (temp) saveRDS(lib.loc, op)
    invisible(TRUE)
}