Skip to content

Commit

Permalink
report: refactoring and tests
Browse files Browse the repository at this point in the history
  • Loading branch information
@stewid
stewid committed Nov 2, 2019
1 parent b2348eb commit 6fa653d
Show file tree
Hide file tree
Showing 4 changed files with 2,292 additions and 116 deletions.
182 changes: 93 additions & 89 deletions R/report.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,6 +53,39 @@ html_summary_table <- function(contacts, direction) {
lines
}

html_contacts_table <- function(x, direction, arrow) {
lines <- "<p>"

## Create the lhs to/from rhs title and add the name of the href
## link
lines <- c(lines,
sprintf('<h3><a name="%s-%s-%s">%s %s %s</a></h3>',
direction, x$lhs[1], x$rhs[1], x$lhs[1], arrow, x$rhs[1]),
"<table border=1>",
"<tr>",
"<th>Date</th>",
"<th>Id</th>",
"<th>N</th>",
"<th>Category</th>",
"<th>Source</th>",
"<th>Destination</th>",
"</tr>")

for (i in seq_len(nrow(x))) {
lines <- c(lines,
"<tr>",
sprintf('<td align="right">%s</td>', x$t[i]),
sprintf('<td align="right">%s</td>', x$id[i]),
sprintf('<td align="right">%s</td>', x$n[i]),
sprintf('<td align="right">%s</td>', x$category[i]),
sprintf('<td align="right">%s</td>', x$source[i]),
sprintf('<td align="right">%s</td>', x$destination[i]),
"</tr>")
}

c(lines, "</table>", "</p>")
}

html_detailed_table <- function(contacts, direction) {
if (identical(direction, "in")) {
arrow <- "&larr;"
Expand All @@ -71,34 +104,10 @@ html_detailed_table <- function(contacts, direction) {
contacts$category <- as.character(contacts$category)
contacts$category[is.na(contacts$category)] <- "&nbsp;"

as.character(unlist(by(contacts, sprintf("%s - %s", contacts$lhs, contacts$rhs), function(x) {
lines <- "<p>"

## Create the lhs to/from rhs title and add the name of the href link
lines <- c(lines,
sprintf('<h3><a name="%s-%s-%s">%s %s %s</a></h3>', direction,
x$lhs[1], x$rhs[1], x$lhs[1], arrow, x$rhs[1]),
"<table border=1>",
"<tr><th>Date</th><th>Id</th><th>N</th><th>Category</th><th>Source</th><th>Destination</th></tr>")

for (i in seq_len(nrow(x))) {
lines <- c(lines,
"<tr>",
sprintf('<td align="right">%s</td>', x$t[i]),
sprintf('<td align="right">%s</td>', x$id[i]),
sprintf('<td align="right">%s</td>', x$n[i]),
sprintf('<td align="right">%s</td>', x$category[i]),
sprintf('<td align="right">%s</td>', x$source[i]),
sprintf('<td align="right">%s</td>', x$destination[i]),
"</tr>")
}

lines <- c(lines,
"</table>",
"</p>")
html <- by(contacts, sprintf("%s - %s", contacts$lhs, contacts$rhs),
html_contacts_table, direction = direction, arrow = arrow)

lines
})))
as.character(unlist(html))
}

html_report <- function(x) {
Expand Down Expand Up @@ -273,6 +282,9 @@ html_report <- function(x) {
##' @param ... Additional arguments to the method
##' @param format the format to use, can be either 'html' or 'pdf'. The default
##' is 'html'
##' @param dir the generated report is written to the directory
##' folder. The default (\code{"."}) is the current working
##' directory.
##' @param template the Sweave template file to use. If none is provided, the default
##' is used.
##' @references \itemize{
Expand All @@ -293,49 +305,39 @@ html_report <- function(x) {
##' Heidelberg, 2002. ISBN 3-7908-1517-9.
##' }
##' @seealso Sweave, texi2pdf.
##' @note Plots are not supported in version 0.8.6 since igraph0 has
##' been archived. We intend to resolve the issue in a future
##' version. Install version 0.8.5 and igraph0 manually from the
##' archive if plots are required. See section 6.3 in 'R Installation
##' and Administration' on how to install packages from source.
##' @keywords methods
##' @importFrom tools texi2pdf
##' @importFrom utils packageVersion
##' @importFrom utils Sweave
##' @examples
##' \dontrun{
##'
##' ## Load data
##' data(transfers)
##'
##' ## Perform contact tracing
##' contactTrace <- Trace(movements=transfers,
##' root=2645,
##' tEnd='2005-10-31',
##' days=90)
##' contactTrace <- Trace(movements = transfers,
##' root = 2645,
##' tEnd = "2005-10-31",
##' days = 90)
##'
##' ## Generate an html report showing details of the contact tracing for
##' ## root 2646.
##' ## Note: Creates the files 2645.html and 2645.png in the working
##' ## directory.
##' Report(contactTrace)
##' ## Creates the file 2645.html in the temporary directory.
##' Report(contactTrace, dir = tempdir())
##'
##' ## It's possible to generate reports for a list of ContactTrace objects.
##' ## Perform contact tracing for ten of the included herds
##' root <- sort(unique(c(transfers$source, transfers$destination)))[1:10]
##'
##' ## Perform contact tracing
##' contactTrace <- Trace(movements=transfers,
##' root=root,
##' tEnd='2005-10-31',
##' days=90)
##' contactTrace <- Trace(movements = transfers,
##' root = root,
##' tEnd = "2005-10-31",
##' days = 90)
##'
##' ## Generate reports
##' ## Note: Creates the files 1.html, 2.html, ..., 10.html and
##' ## 1.png, 2.png, ..., 10.png in the working directory
##' Report(contactTrace)
##' }
##'
##' ## Creates the files 1.html, 2.html, ..., 10.html
##' ## in the temporary directory
##' Report(contactTrace, dir = tempdir())
setGeneric("Report",
signature = "object",
function(object, ...) standardGeneric("Report"))
Expand All @@ -344,60 +346,62 @@ setGeneric("Report",
##' @export
setMethod("Report",
signature(object = "ContactTrace"),
function(object, format = c("html", "pdf"), template = NULL) {
format <- match.arg(format)
function(object, format = c("html", "pdf"),
dir = ".", template = NULL) {
format <- match.arg(format)

if (!is.null(.ct_env$ct)) {
stop("Unable to create report. The ct object already exists")
}

## Make sure the added object is removed.
on.exit(.ct_env$ct <- NULL)

## Add the ContactTrace object to the .ct_env environment
.ct_env$ct <- object
if (!is.null(.ct_env$ct)) {
stop("Unable to create report. The ct object already exists")
}

if (identical(format, "html")) {
writeLines(html_report(object),
con = sprintf("%s.html", object@root))
} else {
if (is.null(template)) {
template <- system.file("Sweave/speak-latex.rnw",
package = "EpiContactTrace")
## Make sure the added object is removed.
on.exit(.ct_env$ct <- NULL)

## Add the ContactTrace object to the .ct_env
## environment
.ct_env$ct <- object

if (identical(format, "html")) {
writeLines(html_report(object),
con = file.path(dir, paste0(object@root, ".html")))
} else {
if (is.null(template)) {
template <- system.file("Sweave/speak-latex.rnw",
package = "EpiContactTrace")
}

Sweave(template, syntax="SweaveSyntaxNoweb")
texi2pdf(sub("rnw$", "tex", basename(template)), clean = TRUE)
file.rename(sub("rnw$", "pdf", basename(template)),
sprintf("%s.pdf", object@root))
unlink(sub("rnw$", "tex", basename(template)))
}

Sweave(template, syntax="SweaveSyntaxNoweb")
texi2pdf(sub("rnw$", "tex", basename(template)), clean = TRUE)
file.rename(sub("rnw$", "pdf", basename(template)),
sprintf("%s.pdf", object@root))
unlink(sub("rnw$", "tex", basename(template)))
invisible(NULL)
}

invisible(NULL)
}
)

##' @rdname Report-methods
##' @export
setMethod("Report",
signature(object = "list"),
function(object, format = c("html", "pdf"), template = NULL) {
format <- match.arg(format)
function(object, format = c("html", "pdf"),
dir = ".", template = NULL) {
format <- match.arg(format)

if (!all(sapply(object, function(x) length(x)) == 1)) {
stop("Unexpected length of list")
}
if (!all(sapply(object, length) == 1)) {
stop("Unexpected length of list")
}

if (!all(sapply(object, function(x) class(x)) == "ContactTrace")) {
stop("Unexpected object in list")
}
if (!all(sapply(object, class) == "ContactTrace")) {
stop("Unexpected object in list")
}

lapply(object, function(x) Report(x,
format = format,
template = template))
lapply(object, Report, dir = dir,
format = format, template = template)

invisible(NULL)
}
invisible(NULL)
}
)

## In order to communicate with Sweave add an environment to store the
Expand Down
46 changes: 19 additions & 27 deletions man/Report-methods.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

56 changes: 56 additions & 0 deletions tests/report.R
View file
Original file line number Diff line number Diff line change
@@ -0,0 +1,56 @@
## Copyright 2013-2019 Stefan Widgren and Maria Noremark,
## National Veterinary Institute, Sweden
##
## Licensed under the EUPL, Version 1.1 or - as soon they
## will be approved by the European Commission - subsequent
## versions of the EUPL (the "Licence");
## You may not use this work except in compliance with the
## Licence.
## You may obtain a copy of the Licence at:
##
## http://ec.europa.eu/idabc/eupl
##
## Unless required by applicable law or agreed to in
## writing, software distributed under the Licence is
## distributed on an "AS IS" basis,
## WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
## express or implied.
## See the Licence for the specific language governing
## permissions and limitations under the Licence.

library(EpiContactTrace)

## Load data
data(transfers)

## Perform contact tracing
contactTrace <- Trace(movements = transfers,
root = 2645,
tEnd = "2005-10-31",
days = 90)

## Generate an html report showing details of the contact tracing for
## root 2646.
## Creates the file 2645.html in the temporary directory.
Report(contactTrace, dir = tempdir())

## Drop line with version and time-stamp
lines <- readLines(file.path(tempdir(), "2645.html"))
lines[c(-9, -1948)]

## It's possible to generate reports for a list of ContactTrace
## objects. Perform contact tracing for two of the included herds
root <- 1:2

## Perform contact tracing
contactTrace <- Trace(movements = transfers,
root = root,
tEnd = "2005-10-31",
days = 90)

## Generate reports Creates the files 1.html, 2645.html in the
## temporary directory
Report(contactTrace, dir = tempdir())

lines <- readLines(file.path(tempdir(), "1.html"))
lines[c(-9, -97)]
Loading

1 comment on commit 6fa653d

@lintr-bot
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

R/network-summary.R:262:1: style: functions should have cyclomatic complexity of less than 15, this has 38.

​setMethod("NetworkSummary",
^

R/report.R:63:1: style: Lines should not be more than 80 characters.

​                       direction, x$lhs[1], x$rhs[1], x$lhs[1], arrow, x$rhs[1]),
^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

R/report.R:151:1: style: Lines should not be more than 80 characters.

​        lines <- c(lines, "<p>No ingoing contacts during the search period.</p>")
^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

R/report.R:288:1: style: Lines should not be more than 80 characters.

​##' @param template the Sweave template file to use. If none is provided, the default
^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

R/report.R:373:42: style: Put spaces around all infix operators.

​                  Sweave(template, syntax="SweaveSyntaxNoweb")
                                        ~^~

R/shortest-paths.R:169:1: style: functions should have cyclomatic complexity of less than 15, this has 41.

​setMethod("ShortestPaths",
^

R/trace.R:161:1: style: functions should have cyclomatic complexity of less than 15, this has 56.

​Trace <- function(movements,
^

R/tree.R:135:1: style: functions should have cyclomatic complexity of less than 15, this has 48.

​position_tree <- function(tree,
^

Please sign in to comment.