\documentclass[11pt,a4paper]{article}

%% *** automatically switched by 'make' ( ./Makefile ) --- CARE!! in changing
\SweaveOpts{echo=FALSE,eval=FALSE,results=hide}   % Exercise mode
%\SweaveOpts{echo=TRUE,eval=TRUE,results=verbatim} % Solution mode
%% other Sweave options
\SweaveOpts{engine=R, keep.source=TRUE, strip.white=true}

\newif\ifSolution
\Solutiontrue% if solution
\Solutionfalse%if exercise
%
\ifSolution\newcommand{\commentSol}[1]{#1}
\else      \newcommand{\commentSol}[1]{}
\fi
\newcommand{\T}[1]{\texttt{#1}}

\begin{document}

<<preliminaries,echo=FALSE,results=hide>>=
options(width = 75, digits = 5, str=list(vec.len=2))
@

We work with the data set \T{airquality} which is part of R....
You can address it simply by \T{airquality}. Use \T{?airquality} to read about the
meaning of the variables contained in the dataset.

Get a summary of the data,
<<s-air-2,echo=TRUE,eval=TRUE>>=
summary(airquality)
@

\commentSol{The data set contains \Sexpr{nrow(airquality)} observations. The data is
complete for all but the first two variables \T{Ozone}, \T{Solar.R},
which contain \Sexpr{sum(is.na(airquality[,1]))} and
\Sexpr{sum(is.na(airquality[,2]))} missing values, respectively.
}

The above works in solution mode,
but in exercise mode, the $\backslash$Sexpr results are put out verbatim,
unfortunately using $\backslash$\verb|verb{bla bla{|  and the left brace
\emph{really} messes up the $\backslash$commentSol\verb|{..}| command...

\end{document}
#  File src/library/utils/tests/Sweave-tst.R
#  Part of the R package, https://www.R-project.org
#
#  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/

## Testing Sweave
if (FALSE) { # Sweave fails under emscripten (throws a syscall error)
.proctime00 <- proc.time()
library(utils)
options(digits = 5) # to avoid trivial printed differences
options(show.signif.stars = FALSE) # avoid fancy quotes in o/p

SweaveTeX <- function(file, ...) {
    if(!file.exists(file))
        stop("File", file, "does not exist in", getwd())
    texF <- sub("\\.[RSrs]nw$", ".tex", file)
    Sweave(file, ...)
    if(!file.exists(texF))
        stop("File", texF, "does not exist in", getwd())
    readLines(texF)
}

p0 <- paste0
latexEnv <- function(lines, name) {
    stopifnot(is.character(lines), is.character(name),
	      length(lines) >= 2, length(name) == 1)
    beg <- p0("\\begin{",name,"}")
    end <- p0("\\end{",name,"}")
    i <- grep(beg, lines, fixed=TRUE)
    j <- grep(end, lines, fixed=TRUE)
    if((n <- length(i)) != length(j))
	stop(sprintf("different number of %s / %s", beg,end))
    if(any(j-1 < i+1))
	stop(sprintf("positionally mismatched %s / %s", beg,end))
    lapply(mapply(seq, i+1,j-1, SIMPLIFY=FALSE),
	   function(ind) lines[ind])
}

## now, Sweave() and check  *.Rnw  examples :

### ------------------------------------ 1 ----------------------------------
t1 <- SweaveTeX("swv-keepSrc-1.Rnw")
if(FALSE)## look at it
writeLines(t1)

inp <- latexEnv(t1, "Sinput")
out <- latexEnv(t1, "Soutput")
## This may have to be updated when the *.Rnw changes:
stopifnot(length(inp) == 5,
	  grepl("#", inp[[2]]), length(inp[[3]]) == 1,
	  length(out) == 1,
	  any(grepl("\\includegraphics", t1)))

### ------------------------------------ 2 ----------------------------------
## Sweave() comments with  keep.source=TRUE
t2 <- SweaveTeX("keepsource.Rnw")
comml <- grep("##", t2, value=TRUE)
stopifnot(length(comml) == 2,
	  grepl("initial comment line", comml[1]),
	  grepl("last comment", comml[2]))
## the first was lost in 2.12.0;  the last in most/all previous versions of R

### ------------------------------------ 3 ----------------------------------
## custom graphics devices
Sweave("customgraphics.Rnw")

### ------------------------------------ 4 ----------------------------------
## SweaveOpts + \Sexpr --> \verb... output
Sweave(f <- "Sexpr-verb-ex.Rnw")
tools::texi2pdf(sub("Rnw$","tex", f))# used to fail


cat('Time elapsed: ', proc.time() - .proctime00,'\n')
}
{
    codepointsToString <- function(x)
        parse(keep.source=FALSE, text=dQuote(q="\"\"", paste0(collapse="",
              sprintf("\\u%04x", as.integer(x)))))[[1]]

    testCharClass <- function(codepoints, class, expected = NULL) {
        stopifnot(is.numeric(codepoints))
        codepoints <- as.integer(codepoints)
        stopifnot(!anyNA(codepoints), all(codepoints > 0))
        if (!is.null(expected))
          stopifnot(length(codepoints) == length(expected),
                    is.logical(expected))

        result <- list()
        result$`charClass(int vs char)` <-
            all.equal(charClass(codepoints, class),
                      charClass(codepointsToString(codepoints), class))
        if (!is.null(expected))
            result$`expected` <- all.equal(expected,
                                           charClass(codepoints, class))
        result <- Filter(Negate(isTRUE), result)
        if (length(result)==0) TRUE else result
    }

    charClasses <- c("alnum", "alpha", "blank", "cntrl", "digit", "graph",
                     "lower", "print", "punct", "space", "upper", "xdigit")
    testCodepoints <- list(
        # "\tAB, ab:3", all ASCII
        ASCII = c(0x0009, 0x0041, 0x0042, 0x002c, 0x0020, 0x0061, 0x0062,
                  0x003a, 0x0033),

        # "Ivan IV", with Ivan in Cyrillic
        Cyrillic = c(0x0418, 0x0432, 0x0430, 0x043d, 0x0020, 0x0049, 0x0056),

        # "Shalom", letters are U+05d0 through U+05ea
        # the others (at 2, 3 and 6) are diacritical marks
        Hebrew = c(0x05E9, 0x05C1, 0x05B8, 0x05DC, 0x05D5, 0x05B9, 0x05DD)) 
                                                                             
    # check for consistency between integer and string inputs
    stopifnot(all(unlist((outer(testCodepoints, charClasses,
        function(x,y) lapply(seq_along(x),
                             function(i) testCharClass(x[[i]],y[i])))))))
}

# spot check return values
{
    stopifnot(all.equal(
        c(TRUE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE),
        charClass(testCodepoints[["ASCII"]], "blank")))
}
{
    stopifnot(all.equal(
        c(FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, TRUE, FALSE),
        charClass(testCodepoints[["ASCII"]], "punct")))
}
{
    stopifnot(all.equal(
        c(FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE),
        charClass(testCodepoints[["ASCII"]], "digit")))
}
{
    stopifnot(all.equal(
        c(FALSE, TRUE, TRUE, FALSE, FALSE, TRUE, TRUE, FALSE, TRUE),
        charClass(testCodepoints[["ASCII"]], "alnum")))
}

# In principle, this can be locale dependent.
# Ubuntu in C locale (without internal iswxxxxx) gives different results. 

if (Sys.getlocale("LC_CTYPE") != "C") {

    stopifnot(all.equal(
        c(TRUE, TRUE, TRUE, TRUE, FALSE, TRUE, TRUE),
        charClass(testCodepoints[["Cyrillic"]], "alpha")))

    stopifnot(all.equal(
        c(TRUE, FALSE, FALSE, FALSE, FALSE, TRUE, TRUE),
        charClass(testCodepoints[["Cyrillic"]], "upper")))

    stopifnot(all.equal(
        c(FALSE, TRUE, TRUE, TRUE, FALSE, FALSE, FALSE),
        charClass(testCodepoints[["Cyrillic"]], "lower")))

    stopifnot(all.equal(
        c(FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE),
        charClass(testCodepoints[["Cyrillic"]], "space")))

    # Ubuntu & Windows 10 disagree about diacritacals
    stopifnot(all(
        charClass(testCodepoints[["Hebrew"]], "alpha")[-c(2,3,6)]))

    # no cases in Hebrew alphabet
    stopifnot(!any(charClass(testCodepoints[["Hebrew"]], "lower")))

    # no cases in Hebrew alphabet
    stopifnot(!any(charClass(testCodepoints[["Hebrew"]], "upper")))
}

## test some typical completion attempts

testLine <- function(line, cursor = nchar(line))
{
    str(utils:::.win32consoleCompletion(line, cursor))
}

testLine("")

testLine("lib")
testLine("data(")
testLine("data(US")
testLine("data(US", 3)

testLine("?INS")

testLine("utils::data")
testLine("utils:::.show_help_on_topic_")
testLine("utils::.show_help_on_topic_")

testLine("update(")

testLine("version$m")
testLine("nchar(version[")



testLine("method?coe")
testLine("?coe")
testLine("?\"coerce,AN")
testLine("method?\"coerce,AN")


## testLine("")
## testLine("")
## testLine("")
Test file for custom graphics devices
<<results=hide>>=
my.Swd <- function(name, width, height, ...) {
  cat("running my.Swd\n")
  grDevices::png(filename = paste(name, "png", sep = "."),
                 width = width, height = height, res = 100, units = "in",
                 bg = "transparent")
}
my.Swd.off <- function() {
    cat("shutting down my.Swd\n")
    grDevices::dev.off()
}
<<fig=TRUE, grdevice=my.Swd>>=
plot(1:2)
<<fig=TRUE, pdf=TRUE, grdevice=my.Swd>>=
plot(1:3)
<<fig=TRUE, grdevice=my.Swd, pdf=TRUE>>=
plot(1:4)
@
Done!

## Tests for HTTP headers -----------------------------------------------

is_online <- function() {
  tryCatch({
    con <- suppressWarnings(socketConnection("8.8.8.8", port = 53))
    close(con)
    con <- url("http://eu.httpbin.org/headers")
    lines <- readLines(con)
    close(con)
    stopifnot(any(grepl("Host.*eu.httpbin.org", lines)))
    TRUE
  }, error = function(e) FALSE)
}

get_headers <- function(path = "anything", quiet = TRUE, ...,
                        protocol = "http") {
  url <- get_path(path, protocol)
  tmp <-  tempfile()
  on.exit(try(unlink(tmp)), add = TRUE)
  download.file(url, tmp, quiet = quiet, ...)
  readLines(tmp)
}

get_headers_url <- function(path = "anything", ..., protocol = "http") {
  con <- url(get_path(path, protocol), ...)
  on.exit(try(close(con)), add = TRUE)
  readLines(con)
}

get_path <- function(path = "anything", protocol = "http") {
  paste0(protocol, "://", "eu.httpbin.org/", path)
}

with_options <- function(opts, expr) {
  old <- do.call(options, as.list(opts))
  on.exit(options(old), add = TRUE)
  expr
}

tests <- function() {
  cat("- User agent is still set\n")
  with_options(list(HTTPUserAgent = "foobar"), {
    h <- get_headers()
    stopifnot(any(grepl("User-Agent.*foobar", h)))
  })

  with_options(list(HTTPUserAgent = "foobar"), {
    h <- get_headers(headers = c(foo = "bar", zzzz = "bee"))
    stopifnot(any(grepl("User-Agent.*foobar", h)))
    stopifnot(any(grepl("Foo.*bar", h)))
    stopifnot(any(grepl("Zzzz.*bee", h)))
  })

  cat("- Can supply headers\n")
  h <- get_headers(headers = c(foo = "bar", zzzz = "bee"))
  stopifnot(any(grepl("Foo.*bar", h)))
  stopifnot(any(grepl("Zzzz.*bee", h)))

  cat("- Basic auth\n")
  ret <- tryCatch({
    h <- suppressWarnings(get_headers(
      "basic-auth/Aladdin/OpenSesame",
      headers = c(Authorization = "Basic QWxhZGRpbjpPcGVuU2VzYW1l")))
    TRUE
  }, error = function(e) FALSE)
  stopifnot(any(grepl("authenticated.*true", h)))

  if (getOption("download.file.method") == "libcurl") {
    cat("- Multiple urls (libcurl only)\n")
    urls <- get_path(c("anything", "headers"))
    tmp1 <- tempfile()
    tmp2 <- tempfile()
    on.exit(unlink(c(tmp1, tmp2)), add = TRUE)
    status <- download.file(urls, c(tmp1, tmp2), quiet = TRUE,
                            headers = c(foo = "bar", zzzz = "bee"))
    if (status == 0L) {
        h1 <- readLines(tmp1)
        h2 <- readLines(tmp2)
        stopifnot(any(grepl("Foo.*bar", h1)))
        stopifnot(any(grepl("Zzzz.*bee", h1)))
        stopifnot(any(grepl("Foo.*bar", h2)))
        stopifnot(any(grepl("Zzzz.*bee", h2)))
    }
  }

  cat("- HTTPS\n")
  h <- get_headers(headers = c(foo = "bar", zzzz = "bee"), protocol = "https")
  stopifnot(any(grepl("Foo.*bar", h)))
  stopifnot(any(grepl("Zzzz.*bee", h)))

  cat("- If headers not named, then error\n")
  ret <- tryCatch(
    download.file(get_path(), headers = c("foo", "xxx" = "bar")),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))
  ret <- tryCatch(
    download.file(get_path(), headers = "foobar"),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))

  cat("- If headers are NA, then error\n")
  ret <- tryCatch(
    download.file(get_path(), headers = c("foo" = NA, "xxx" = "bar")),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))
  ret <- tryCatch(
    download.file(
      get_path(), quiet = TRUE,
      headers = structure(c("foo", "bar", names = c("foo", NA)))),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))

  cat("- user agent is set in url()\n")
  with_options(list(HTTPUserAgent = "foobar"), {
    h <- get_headers_url()
    stopifnot(any(grepl("User-Agent.*foobar", h)))
  })

  cat("- file() still works with URLs\n")
  con <- file(get_path("anything", "http"))
  on.exit(close(con), add = TRUE)
  h <- readLines(con)
  stopifnot(any(grepl("Host.*eu.httpbin.org", h)))

  cat("- If headers not named, then url() errors\n")
  ret <- tryCatch(
    url(get_path(), headers = c("foo", "xxx" = "bar")),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))

  cat("- If headers are NA, then url() errors\n")
  ret <- tryCatch(
    url(get_path(), headers = c("foo" = "bar", "xxx" = NA)),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))
  ret <- tryCatch(
    url(get_path(),
        headers = structure(c("1", "2"), names = c("foo", NA))),
    error = function(err) TRUE)
  stopifnot(isTRUE(ret))

  cat("- Can supply headers in url()\n")
  h <- get_headers_url(headers = c(foo = "bar", zzzz = "bee"))
  stopifnot(any(grepl("Foo.*bar", h)))
  stopifnot(any(grepl("Zzzz.*bee", h)))

  cat("- HTTPS with url()\n")
  h <- get_headers_url(headers = c(foo = "bar", zzzz = "bee"),
                       protocol = "https")
  stopifnot(any(grepl("Foo.*bar", h)))
  stopifnot(any(grepl("Zzzz.*bee", h)))
}

main <- function() {
    if (capabilities("libcurl")) {
        cat("\nlibcurl method\n")
        with_options(c(download.file.method = "libcurl"), tests())
    }

    if (.Platform$OS.type == "windows")  {
        ## This is deprecated and will give warnings.
        cat("\nwininet method\n")
        with_options(c(download.file.method = "wininet"), tests())
    }
}

options(warn = 1)

if (is_online()) main()
\SweaveOpts{keep.source=TRUE}

Now a chunk starting with a comment, lost in R 2.12.0 patched:
<<ex>>=
## This is an initial comment line. Let's hope it's not being lost
"Above there's a comment."
1:10 # a comment here is preserved
pi   # also, there's one the next (last) line - which used to get lost
## and a last comment here ... lost also in earlier R versions
@

and some more text.
## PR#15854
local({
    ## This always worked
    x <- as.relistable(list(integer(), 1:2, double(), 3))
    vec <- unlist(x)
    vec[[2]] <- 10
    stopifnot(identical(relist(vec),
                        as.relistable(list(double(), c(1, 10), double(), 3))))
    ## Used to fail, Error .. The 'flesh' argument does not contain a skeleton attribute. ...
    x <- as.relistable(list(integer(), 1:2, NULL, 3))
    vec <- unlist(x)
    vec[[2]] <- 10
    stopifnot(identical(relist(vec),
                        as.relistable(list(double(), c(1, 10), double(), 3))))
    ## ditto in PR#..:
    x <- list(NULL, a=1:3, b=5:7)
    y <- unlist(as.relistable(x))
    stopifnot(identical(relist(y),
                        as.relistable(list(`names<-`(integer(),character()),
                                           a=1:3, b=5:7))))
    ## relist(y) gave Error ... :
    ##   The 'flesh' argument does not contain a skeleton attribute.
    ##   Either ensure you unlist a relistable object, or specify the skeleton separately.
})
\documentclass{article}
\SweaveOpts{engine=R,eps=FALSE,pdf=TRUE,strip.white=true,keep.source=TRUE}

\usepackage{Sweave}

\begin{document}
<<preliminaries, echo=FALSE, results=hide>>=
options(width=70, useFancyQuotes = FALSE, prompt="R> ", continue="+  ")
@
\subsection*{Introduction}

We generate 3D gaussian data,
We generate 3D Gaussian data,
<<ex1-U3>>=
set.seed(1)
n <- 100
x <- rnorm(n); y <- 2*x + rnorm(n)/2
U3 <- cbind(x, y, z = -3*x + y + rnorm(n)/4)
@
look at its structure
<<str>>=
str(U3) # its structure ((comment kept))
@
and load package \texttt{lattice}
<<req-lattice>>=
if(!require("lattice", quietly = TRUE)) q("no")
@
to visualize it by a simple scatter plot matrix
\begin{figure}[h!]
\centering
<<splom-def, eval=false>>=
splom(U3, xlab ="", cex = 0.4)
<<splom, echo=FALSE, fig=TRUE, height=5>>=
print(
<<splom-def>>
     )
@
\caption{\Sexpr{n} vectors of random variates ... ...}
\label{fig:AC_Joe}
\end{figure}

\subsection*{Session Information}

<<sessionInfo, results=tex>>=
toLatex(sessionInfo())
@

\end{document}
