cat("\n ** Starting .RProfile **")
options(rstudio.markdownToHTML = 
  function(inputFile, outputFile) {      
    require(markdown)
    htmlOptions <- markdownHTMLOptions(defaults=TRUE)
    # LibreOffice hangs when the png is included in the html file
    # I have therefore this option where you actively 
    # have to choose inline if you want the png to be inline
    if (getOption("base64_images", "No") != "inline")
      htmlOptions <- htmlOptions[htmlOptions != "base64_images"]
 
    # Now in this section we skip writing to the outputfile
    # and keep the markdown text in the md_txt variable
    md_txt <- markdownToHTML(inputFile, options = htmlOptions,
                   stylesheet=ifelse(file.exists('custom.css'), 
                                     'custom.css',
                                     getOption("markdown.HTML.stylesheet")))
 
    if (getOption("LibreOffice_adapt", "Yes") == "skip"){
      writeLines(md_txt, con=outputFile)
    }else{
      # Annoyingly it seems that Libre Office currently 
      # 'forgets' the margin properties of the headers,
      # we therefore substitute these with a element specific
      # style option that works. Perhaps not that pretty but
      # it works and can be tweaked for most things.
      writeLines(
        gsub("<h([0-9]+)>", 
             "<h\\1 style='margin: 10pt 0pt 0pt 0pt;'>", 
             gsub("<h1>",
                  "<h1 style='margin: 24pt 0pt 0pt 0pt;'>",
                  md_txt)), 
        con=outputFile)
    }
  }
)
 
# I’ve  added some automated comments just as a reminder, remove
# the cat() if you want the .RProfile to be quiet (note, the output does
# not affect the knitr document)
cat("\n * If you want knitr markdown png-files to be inside the document",
    " then set the options(base64_images = 'inline') for it to work.")
cat("\n * If you don't want the Libre Office adaptations then set",
    " options(LibreOffice_adapt = 'skip')")
cat("\n * If you want knitr markdown to use a custom css then",
    " just input a 'custom.css' file in the Rmd file's directory.")
cat("\n ** End .RProfile **\n")

/* Set the main font to Calibri, same 
   as My Word 2010 uses. Also set the 
   default font size to 11pt.
 
   The maximum width to 35em enhances 
   readability through optimal line 
   length. Note: this setting is ignored
   by Word/Libre Office*/
body  {
   font-family: Calibri;
   font-size: 11pt;
   background-color: white;
   padding-top: 1em;
   margin: auto;
   max-width: 35em;
}
 
/* Set the paragraph margin and 
   padding to 0 except for the bottom */
p {
  padding: 0;
  margin: 0;
  margin-bottom: 10pt;
}
 
/* Center the table and add top/bottom margins */
table{
  margin: auto;
  margin-top: 1em;
  margin-bottom: 1em;
  border: none;
}
 
/* The tr padding/margin 0 is important for table
   import, while the font needs to be specified as
   font and not font-family/font-size due to limiations
   in Libre Office */
td, tr{
  font: 10pt Arial;
  padding: 0px;
  margin: 0px;
}
 
/* The cell should have a little space to easy reading
   although this section is mostly ignored by the 
   Libre Office import */
td {
  padding: 4px;
  padding-bottom: 2px;
}
 
/* Set the headings to correspond to Word-style */
h1, h2, h3, h4, h5, h6 {
  margin: 10pt 0pt 0pt 0pt;
  font-family: Cambria;
  font-weight: bold;
}
 
/* h1 has a slightly larger top margins 
   so we re-set that from the other*/
h1 {
  margin: 24pt 0pt 0pt 0pt;
  font-size: 14pt;
  color: #365F91;
}
 
 
h2 {
  font-size: 13pt;
  color: #4F81BD;
}
 
h3 {
  font-size: 11pt;
  color: #4F81BD;
}
 
h4 {
  font-size: 11pt;
  font-weight: bold;
  font-style: italic;
  color: #4F81BD;
}
 
h5 {
  font-size: 11pt;
  font-weight: normal;
  color: #243F5D;
}
 
h6 {
  font-size: 11pt;
  font-weight: normal;
  font-style: italic;
  color: #243F5D;
}
 
/* The following sections are mostly 
   unrelated to Word/Libre Office imports */
tt, code, pre {
   font-family: 'DejaVu Sans Mono', 'Droid Sans Mono', 'Lucida Console', Consolas, Monaco, monospace;
}
 
a:visited {
   color: rgb(50%, 0%, 50%);
}
 
pre {  
   margin-top: 0;
   max-width: 95%;
   border: 1px solid #ccc;
   white-space: pre-wrap;
}
 
pre code {
   display: block; padding: 0.5em;
}
 
code.r, code.cpp {
   background-color: #F8F8F8;
}
 
blockquote {
   color:#666666;
   margin:0;
   padding-left: 1em;
   border-left: 0.5em #EEE solid;
}
 
hr {
   height: 0px;
   border-bottom: none;
   border-top-width: thin;
   border-top-style: dotted;
   border-top-color: #999999;
}
 
@media print {
   * {
      background: transparent !important;
      color: black !important;
      filter: none !important;
      -ms-filter: none !important;
   }
 
   body {
      font-size:11pt;
      max-width:100%;
   }
 
   a, a:visited {
      text-decoration: underline;
   }
 
   hr {
      visibility: hidden;
      page-break-before: always;
   }
 
   pre, blockquote {
      padding-right: 1em;
      page-break-inside: avoid;
   }
 
   tr, img {
      page-break-inside: avoid;
   }
 
   img {
      max-width: 100% !important;
   }
 
   @page {
      margin-top: 2cm;
      margin-bottom: 1.5cm;
      margin-left: 3cm;
      margin-right: 3cm;
   }
 
   p, h2, h3 {
      orphans: 3; widows: 3;
   }
 
   h2, h3 {
      page-break-after: avoid;
   }
}

p {
  padding: 0;
  margin: 0pt 0pt 10pt 0pt;
}

p {
  padding: 0;
  margin: 0pt;
  margin-bottom: 10pt;
}

h1, h2, h3, h4, h5, h6 {
  margin: 10pt 0pt 0pt 0pt;
  font-family: Cambria;
  font-weight: bold;
}

h1 {
  margin: 24pt 0pt 0pt 0pt;
  font-size: 14pt;
  color: #365F91;
}

library(knitr)
 
# Notify that you want to use the counter,
# if you set the counter to 3 then it will use 
# that as starting number. You can also use strings
# if you for instance have a split figure with 
# a "1a" and "1b" setup
options(figure_counter = TRUE)
 
# If you want roman letters then set: 
# options(figure_counter_roman = TRUE)
 
# Evaluate the figure caption after the chunk, 
# sometimes you want to calculate stuff inside the
# chunk that you want to include in the caption and
# it is therefore useful to evaluate it afterwards.
opts_knit$set(eval.after='fig.cap')
 
# The actual hook
knit_hooks$set(plot = function(x, options) {
  fig_fn = paste0(opts_knit$get("base.url"), 
                  paste(x, collapse = "."))
 
  # Some stuff from the default definition
  fig.cap <- knitr:::.img.cap(options)
 
  # Style and additional options that should be included in the img tag
  style=c("display: block",
          sprintf("margin: %s;",
                   switch(options$fig.align, 
                          left = 'auto auto auto 0', 
                          center = 'auto',
                          right = 'auto 0 auto auto')))
  # Certain arguments may not belong in style, 
  # for instance the width and height are usually
  # outside if the do not have a unit specified
  addon_args = ""
 
  # This is perhaps a little overly complicated prepared 
  # with the loop but it allows for a more out.parameters if necessary
  if (any(grepl("^out.(height|width)", names(options)))){
      on <- names(options)[grep("^out.(height|width)", names(options))]
      for(out_name in on){
          dimName <- substr(out_name, 5, nchar(out_name))
          if (grepl("[0-9]+(em|px|%|pt|pc|in|cm|mm)", out_name))
              style=append(style, paste0(dimName, ": ", options[[out_name]]))
          else if (length(options$out.width) > 0)
              addon_args = paste0(addon_args, dimName, "='", options[[out_name]], "'")
      }
  }
 
  # Add counter if wanted
  fig_number_txt <- ""
  cntr <- getOption("figure_counter", FALSE)
  if (cntr != FALSE){
    if (is.logical(cntr))
      cntr <- 1
    # The figure_counter_str allows for custom 
    # figure text, you may for instance want it in
    # bold: <b>Figure %s:</b>
    # The %s is so that you have the option of setting the
    # counter manually to 1a, 1b, etc if needed
    fig_number_txt <- 
      sprintf(getOption("figure_counter_str", "Figure %s: "), 
              ifelse(getOption("figure_counter_roman", FALSE), 
                     as.character(as.roman(cntr)), as.character(cntr)))
 
    if (is.numeric(cntr))
      options(figure_counter = cntr + 1)
  }
 
  # Put it all together
  paste0("<figure><img src='", fig_fn, "'", 
         " ", addon_args,
         paste0(" style='", paste(style, collapse="; "), "'"),
         ">",
         "<figcaption>", fig_number_txt, fig.cap, "</figcaption></figure>")
})

library(knitr)
opts_chunk$set(dev="png", 
               dev.args=list(type="cairo"),
               dpi=96)

library(knitr)
opts_chunk$set(dev='postscript')

library(knitr)
opts_chunk$set(dev="tiff", 
               dev.args=list(compression="lzw"),
               dpi=300)

# The code for the x-mark
library(ggplot2)
polygon_df1 <- data.frame(x=c(0,0.75,1,.25), y=c(0,1,1,0))
polygon_df2 <- data.frame(x=c(0,0.75,1,.25), y=c(1,0,0,1))
ggplot(polygon_df1, aes(x=x, y=y)) +
  geom_polygon(fill="steelblue", col="steelblue") +
  geom_polygon(data=polygon_df2, fill="#55558899", col="#55558899") +
  scale_x_continuous(expand = c(0,0)) + 
  scale_y_continuous(expand = c(0,0)) +
  xlab("") + ylab("") +   theme(line = element_blank(),
        text = element_blank(),
        line = element_blank(),
        title = element_blank())

opts_chunk$set(dev="png", 
               dev.args=list(type="cairo"),
               dpi=96)

library(ggplot2)
line <- data.frame(x=c(0.25,1), y=c(1,.45))
polygon <- data.frame(x=c(0,0.75,1,0), y=c(.75,.20,.20,1))
aa <- ggplot(line, aes(x=x, y=y)) +
  geom_line(fill="steelblue", col="steelblue", lwd=2) +
  geom_polygon(data=polygon, fill="#555588", col="#555588") +
  scale_x_continuous(expand = c(0,0)) + 
  scale_y_continuous(expand = c(0,0)) +
  theme_bw() + 
  xlab("") + ylab("") + 
  theme(line = element_blank(),
        text = element_blank())
 
aa + annotate("text", label="Not\nanti-\naliased", 
           size=6, y=.93, x=.7)

library(boot)
 
# Set time to years instead of days
melanoma$time_years <- 
  melanoma$time / 365.25
 
# Factor the basic variables that 
# we're interested in
melanoma$status <- 
  factor(melanoma$status, 
         levels=c(2,1,3),
         labels=c("Alive", # Reference
                  "Melanoma death", 
                  "Non-melanoma death"))
melanoma$sex <- 
  factor(melanoma$sex,
         labels=c("Male", 
                  "Female"))
 
melanoma$ulcer <- 
  factor(melanoma$ulcer,
         labels=c("Present", 
                  "Absent"))

# A function that takes the variable name,
# applies it to the melanoma dataset
# and then runs the results by the status variable
getT1Stat <- function(varname, digits=0){
  getDescriptionStatsBy(melanoma[, varname], 
                        melanoma$status, 
                        add_total_col=TRUE,
                        show_all_values=TRUE, 
                        hrzl_prop=TRUE,
                        statistics=FALSE, 
                        html=TRUE, 
                        digits=digits)
}
 
# Save everything in a list
# This simplifies the row grouping 
table_data <- list()
 
# Get the basic stats
table_data[["Sex"]] <- getT1Stat("sex")
table_data[["Age"]] <- getT1Stat("age")
table_data[["Ulceration"]] <- getT1Stat("ulcer")
table_data[["Thickness<sup>a</sup>"]] <- getT1Stat("thickness", 1)

# A function that takes the variable name,
# applies it to the melanoma dataset
# and then runs the results by the status variable
getT1Stat <- function(varname, digits=0){
  getDescriptionStatsBy(melanoma[, varname], 
                        melanoma$status, 
                        add_total_col=TRUE,
                        show_all_values=TRUE, 
                        hrzl_prop=TRUE,
                        statistics=FALSE, 
                        html=TRUE, 
                        digits=digits,
                        continuous_fn=describeMedian)
}

# Now merge everything into a matrix
# and create the rgroup & n.rgroup variabels
rgroup <- c()
n.rgroup <- c()
output_data <- NULL
for (varlabel in names(table_data)){
  output_data <- rbind(output_data, 
                       table_data[[varlabel]])
  rgroup <- c(rgroup, 
              varlabel)
  n.rgroup <- c(n.rgroup, 
                nrow(table_data[[varlabel]]))
}
 
 
# Add a column spanner for the death columns
cgroup <- c("", "Death")
n.cgroup <- c(2, 2)
colnames(output_data) <- gsub("[ ]*death", "", colnames(output_data))
 
htmlTable(output_data, align="rrrr",
          rgroup=rgroup, n.rgroup=n.rgroup, 
          rgroupCSSseparator="", 
          cgroup = cgroup,
          n.cgroup = n.cgroup,
          rowlabel="", 
          caption="Basic stats", 
          tfoot="<sup>a</sup> Also known as Breslow thickness", 
          ctable=TRUE)

# Setup needed for the rms coxph wrapper
ddist <- datadist(melanoma)
options(datadist = "ddist")
fit <- cph(Surv(melanoma$time, melanoma$status=="Melanoma death") ~
               sex + age + thickness + ulcer, data=melanoma)
 
printCrudeAndAdjustedModel(fit, desc_digits=0,
                           caption="Crude and adjusted estimates",
                           desc_column=TRUE,
                           add_references=TRUE, 
                           ctable=TRUE)

round(3.901, digits=2) # 3.9
round(3.901, digits=3) # 3.901
 
# The format function works better although
# you need to remember the nsmall option:
# "the minimum number of digits to the right of the decimal point"
format(3.901, digits=2) # 3.9
format(3.901, digits=2, nsmall=2) # 3.90
format(3.901, digits=3, nsmall=2) # 3.90
format(3.901, digits=4, nsmall=2) # 3.901
 
sprintf("%.2f", 3.901) # 3.90
sprintf("%.1f HR (95 %% CI %.1f to %.1f)", 
        exp(coef(fit)), 
        exp(confint(fit)[,1]), 
        exp(confint(fit)[,2]))
# "0.9 HR (95 % CI 0.6 to 1.4)" 
# "1.0 HR (95 % CI 1.0 to 1.0)"
# "1.0 HR (95 % CI 0.7 to 1.4)"

pvalue_formatter <- function(pvalues, sig.limit = 0.001){
  sapply(pvalues, function(x, sig.limit){
    if (x < sig.limit)
      return(sprintf("&lt; %s", format(sig.limit))) 
    # &lt; stands for < and is needed
    # for the markdown/html to work
    # and the format is needed to avoid trailing zeros
 
    # High p-values you usually want two decimals
    # otherwise report only one
    if (x > 0.01)
      return(format(x, digits=2))
 
    return(format(x, digits=1))
    }, sig.limit=sig.limit)
}
 
pv <- c(.133213, .0611233, .004233, .00000123123)
pvalue_formatter(pv)
# "0.13"
# "0.061"
# "0.004"
# "&lt; 0.001"

col <- sprintf("Cell %d:%%d", 1:9)
vars <- sapply(1:3, function(i) sprintf(col, i))
 
rownames(vars) <- sprintf("Row no. %d", 1:nrow(vars))
colnames(vars) <- sprintf("Column<br />no. %d", 1:3)
cgroup <- c("", "Column spanner")
n.cgroup <- c(1, 2)
rgroup <- c("Stub I", "", "Stub II")
n.rgroup <- c(2, 3, nrow(vars) - 2 - 3)
htmlTable(vars, 
          rowlabel="Row label", 
          cgroup=cgroup, n.cgroup=n.cgroup, 
          rgroup=rgroup, n.rgroup = n.rgroup, 
          rgroupCSSstyle="", rgroupCSSseparator="", 
          caption="Basic table<sup>&dagger;</sup> anatomy", 
          tfoot="<sup>&dagger;</sup> Put your explanations in the table footer",
          ctable=TRUE)

library(xtable)
alt_vars <- cbind(
  Rowgrp1 = c("Mjr group 1", "", "", 
              "Mjr group 2", "", "", "", "", ""),
  Rowgrp2 = c("Group 1", "", "", 
              "Group 2", "", 
              "Group 3", "", "", ""),
  Rownames= rownames(vars), 
  vars)
colnames(alt_vars) <- gsub("<br />", "\n", colnames(alt_vars))
# rownames(vars) <- NULL
options(xtable.html.table.attributes = 
          list(style=sprintf("style='%s'",
                             paste("border:0",
                                   "border-top: 1px solid grey", 
                                   "border-bottom: 1px solid grey",
                                   sep="; "))))
print(xtable(alt_vars, caption="An xtable example"), type="html", include.rownames = FALSE)

```{r Data_prep, echo=FALSE, message=FALSE, warning=FALSE}
# Moved this outside the document for easy of reading
# I often have those sections in here
source("Setup_and_munge.R")
```
 
```{r Versions}
info <- sessionInfo()
r_ver <- paste(info$R.version$major, info$R.version$minor, sep=".")
```
 
All analyses were performed using R (ver. `r r_ver`)[R Core Team, 2013] 
and packages rms (ver. `r info$otherPkgs$rms$Version`) [F. Harrell, 2014] 
for analysis, Gmisc for plot and table output (ver. `r info$otherPkgs$Gmisc$Version`), 
and knitr (ver `r info$otherPkgs$knitr$Version`) [Xie, 2013] for reproducible research.
 
Results
=======
 
We found `r nrow(melanoma)` patients with malignant melanoma between the years 
`r paste(range(melanoma$year), collapse=" and ")`. Patients were followed until 
the end of 1977, the median follow-up time was `r sprintf("%.1f", median(melanoma$time_years))` 
years (range `r paste(sprintf("%.1f", range(melanoma$time_years)), collapse=" to ")` years). 
Males were more common than females and had also a higher mortality rate.
 
```{r Table1, results='asis', cache=FALSE}
table_data <- list()
getT1Stat <- function(varname, digits=0){
  getDescriptionStatsBy(melanoma[, varname], melanoma$status, 
                        add_total_col=TRUE,
                        show_all_values=TRUE, 
                        hrzl_prop=TRUE,
                        statistics=FALSE, 
                        html=TRUE, 
                        digits=digits)
}
 
# Get the basic stats
table_data[["Sex"]] <- getT1Stat("sex")
table_data[["Age<sup>&dagger;</sup>"]] <- getT1Stat("age")
table_data[["Ulceration"]] <- getT1Stat("ulcer")
table_data[["Thickness<sup>&Dagger;</sup>"]] <- getT1Stat("thickness", digits=1)
 
# Now merge everything into a matrix
# and create the rgroup & n.rgroup variabels
rgroup <- c()
n.rgroup <- c()
output_data <- NULL
for (varlabel in names(table_data)){
  output_data <- rbind(output_data, table_data[[varlabel]])
  rgroup <- c(rgroup, varlabel)
  n.rgroup <- c(n.rgroup, nrow(table_data[[varlabel]]))
}
 
# Add a column spanner for the death columns
cgroup <- c("", "Death")
n.cgroup <- c(2, 2)
colnames(output_data) <- gsub("[ ]*death", "", colnames(output_data))
 
htmlTable(output_data, align="rrrr",
          rgroup=rgroup, n.rgroup=n.rgroup, 
          rgroupCSSseparator="", 
          cgroup = cgroup,
          n.cgroup = n.cgroup,
          rowlabel="", 
          caption="Baseline characteristics", 
          tfoot=paste0("<sup>&dagger;</sup> Age at the time of surgery.",
                       " <br/><sup>&Dagger;</sup> Tumour thicknes,",
                       " also known as Breslow thickness, measured in mm."), 
          ctable=TRUE)
```
 
Main results
------------
 
```{r C_and_A, results='asis'}
# Setup needed for the rms coxph wrapper
ddist <- datadist(melanoma)
options(datadist = "ddist")
 
# Do the cox regression model 
# for melanoma specific death
msurv <- Surv(melanoma$time_years, melanoma$status=="Melanoma death")
fit <- cph(msurv ~ sex + age + ulcer + thickness, data=melanoma)
 
# Print the model
printCrudeAndAdjustedModel(fit, desc_digits=0,
                           caption="Adjusted and unadjusted estimates for melanoma specific death.",
                           desc_column=TRUE,
                           add_references=TRUE, 
                           ctable=TRUE)
 
pvalues <- 
  1 - pchisq(coef(fit)^2/diag(vcov(fit)), df=1)
```
 
```{r}
pvalue_formatter <- function(pvalues, sig.limit = 0.001){
  sapply(pvalues, function(x, sig.limit){
    if (x < sig.limit)
      return(sprintf("&lt; %s", format(sig.limit))) 
    # &lt; stands for < and is needed
    # for the markdown/html to work
    # and the format is needed to avoid trailing zeros
 
    # High p-values you usually want two decimals
    # otherwise report only one
    if (x > 0.01)
      return(format(x, digits=2))
 
    return(format(x, digits=1))
    }, sig.limit=sig.limit)
}
```
 
After adjusting for the three variables, age, sex, tumor thickness 
and ulceration, only the latter two remained significant (p-value 
`r pvalue_formatter(pvalues["ulcer=Present"])` and 
`r pvalue_formatter(pvalues["thickness"])`), 
see table `r as.numeric(options("table_counter"))-1` 
and figure `r getNextFigureNo()`.
 
```{r Regression_forestplot, fig.height=3, fig.width=5, fig.cap="A foresplot comparing the regression coefficients."}
# I've adjusted the coefficient for age to be by 
forestplotRegrObj(update(fit, .~.-age+I(age/10)), 
                  order.regexps=c("Female", "age", "ulc", "thi"),
                  box.default.size=.25, xlog=TRUE,
                  new_page=TRUE, clip=c(.5, 6), rowname.fn=function(x){
  if (grepl("Female", x))
    return("Female")
 
  if (grepl("Present", x))
    return("Ulceration")
 
  if (grepl("age", x))
    return("Age/10 years")
 
  return(capitalize(x))
})
```
 
There was no strong indication for non-linearity for any of the 
continuous variables although the impact of thickness did 
seem to lessen above 4 mm, see figure `r getNextFigureNo()`.
 
```{r spline_plot, fig.cap=plotHR_cap}
plotHR_cap = paste0("The adjusted and unadjusted restricted cubic spline",
                    " for tumor thickness. Solid line and confidence interval",
                    " indicate the adjusted line while the dashed is",
                    " the unadjusted line. The grey area at ",
                    " the bottom indicates the density.")
# Generate adjusted and anuadjusted regression models
rcs_fit <- update(fit, .~.-thickness+rcs(thickness, 3))
rcs_fit_ua <- update(fit, .~+rcs(thickness, 3))
 
# Make sure the axes stay at the exact intended points
par(xaxs="i", yaxs="i")
plotHR(list(rcs_fit, rcs_fit_ua), col.dens="#00000033",
       lty.term=c(1, 2),
       col.term=c("blue", "#444444"), 
       col.se = c("#0000FF44", "grey"),
       polygon_ci=c(TRUE, FALSE),
       term="thickness", 
       xlab="Thickness (mm)", 
       ylim=c(.1, 4), xlim=c(min(melanoma$thickness), 4), 
       plot.bty="l", y.ticks=c(.1, .25, .5, 1, 2, 4))
legend(x=.1, y=1.1, legend=c("Adjusted", "Unadjusted"), fill=c("blue", "grey"), bty="n")
```

##################
# Knitr settings #
##################
 
# Load the knitr package so that the code
# doesn't complain outside knitr
library(knitr) 
 
# Set some basic options. You usually do not
# want your code, messages, warnings etc
# to show in your actual manuscript
opts_chunk$set(warning=FALSE, 
               message=FALSE, 
               echo=FALSE, 
               dpi=96,
               fig.width=4, fig.height=4, # Default figure widths
               dev="png", dev.args=list(type="cairo"), # The png device
               # Change to dev="postscript" if you want the EPS-files
               # for submitting. Also remove the dev.args() as the postscript
               # doesn't accept the type="cairo" argument.
               error=FALSE)
 
# Evaluate the figure caption after the plot
opts_knit$set(eval.after='fig.cap')
 
# Avoid including base64_images - this only 
# works with the .RProfile setup
options(base64_images = "none")
 
# Use the table counter that the htmlTable() provides
options(table_counter = TRUE)
 
# Use the figure counter that we declare below
options(figure_counter = TRUE)
# Use roman letters (I, II, III, etc) for figures
options(figure_counter_roman = TRUE)
 
# Adding the figure number is a little tricky when the format is roman
getNextFigureNo <- function() as.character(as.roman(as.numeric(options("figure_counter"))))
 
# Add a figure counter function
knit_hooks$set(plot = function(x, options) {
  fig_fn = paste0(opts_knit$get("base.url"), 
                  paste(x, collapse = "."))
 
  # Some stuff from the default definition
  fig.cap <- knitr:::.img.cap(options)
 
  # Style and additional options that should be included in the img tag
  style=c("display: block",
          sprintf("margin: %s;",
                   switch(options$fig.align, 
                          left = 'auto auto auto 0', 
                          center = 'auto',
                          right = 'auto 0 auto auto')))
  # Certain arguments may not belong in style, 
  # for instance the width and height are usually
  # outside if the do not have a unit specified
  addon_args = ""
 
  # This is perhaps a little overly complicated prepared 
  # with the loop but it allows for a more out.parameters if necessary
  if (any(grepl("^out.(height|width)", names(options)))){
      on <- names(options)[grep("^out.(height|width)", names(options))]
      for(out_name in on){
          dimName <- substr(out_name, 5, nchar(out_name))
          if (grepl("[0-9]+(em|px|%|pt|pc|in|cm|mm)", out_name))
              style=append(style, paste0(dimName, ": ", options[[out_name]]))
          else if (length(options$out.width) > 0)
              addon_args = paste0(addon_args, dimName, "='", options[[out_name]], "'")
      }
  }
 
  # Add counter if wanted
  fig_number_txt <- ""
  cntr <- getOption("figure_counter", FALSE)
  if (cntr != FALSE){
    if (is.logical(cntr))
      cntr <- 1
    # The figure_counter_str allows for custom 
    # figure text, you may for instance want it in
    # bold: <b>Figure %s:</b>
    # The %s is so that you have the option of setting the
    # counter manually to 1a, 1b, etc if needed
    fig_number_txt <- 
      sprintf(getOption("figure_counter_str", "Figure %s: "), 
              ifelse(getOption("figure_counter_roman", FALSE), 
                     as.character(as.roman(cntr)), as.character(cntr)))
 
    if (is.numeric(cntr))
      options(figure_counter = cntr + 1)
  }
 
  # Put it all together
  paste0("<figure><img src='", fig_fn, "'", 
         " ", addon_args,
         paste0(" style='", paste(style, collapse="; "), "'"),
         ">",
         "<figcaption>", fig_number_txt, fig.cap, "</figcaption></figure>")
})
 
#################
# Load_packages #
#################
library(rms) # I use the cox regression from this package
library(boot) # The melanoma data set is used in this exampe
library(Gmisc) # Stuff I find convenient
 
##################
# Munge the data #
##################
 
# Here we go through and setup the variables so that
# they are in the proper format for the actual output
 
# Load the dataset - usually you would use read.csv
# or something similar
data("melanoma")
 
# Set time to years instead of days
melanoma$time_years <- 
  melanoma$time / 365.25
 
# Factor the basic variables that 
# we're interested in
melanoma$status <- 
  factor(melanoma$status, 
         levels=c(2, 1, 3),
         labels=c("Alive", # Reference
                  "Melanoma death", 
                  "Non-melanoma death"))
melanoma$sex <- 
  factor(melanoma$sex,
         labels=c("Male", # Reference
                  "Female"))
 
melanoma$ulcer <- 
  factor(melanoma$ulcer,
         levels=0:1,
         labels=c("Absent", # Reference
                  "Present"))

library(Gmisc)
Sweden <- 
  structure(
            c(0.0408855062954068, -0.0551574080806885,
              -0.0383305964199184, -0.0924757229652802, 
              0.0348395599810297, -0.0650808763059716, 
              -0.0472794647337126, -0.120200006386798, 
              0.046931452609784, -0.0452339398554054, 
              -0.0293817281061242, -0.0647514395437626), 
            .Dim = c(4L, 3L), 
            .Dimnames = list(c("Males vs Female", "85 vs 65 years", 
                              "Charlsons Medium vs Low", "Charlsons High vs Low"), 
                             c("coef", "lower", "upper")))
 
Denmark <- 
  structure(
            c(0.0346284183072541, -0.0368279085760325,
              -0.0433553672510346, -0.0685734649940999, 
              0.00349437418972517, -0.0833673052667752, 
              -0.0903366633240568, -0.280756832078775, 
              0.065762462424783, 0.00971148811471034, 
              0.00362592882198759, 0.143609902090575),
            .Dim = c(4L, 3L), 
            .Dimnames = list(c("Males vs Female", "85 vs 65 years", 
                               "Charlsons Medium vs Low", "Charlsons High vs Low"), 
                             c("coef", "lower", "upper")))

forestplot2(mean=cbind(Sweden[,"coef"], Denmark[,"coef"]), 
            lower=cbind(Sweden[,"lower"], Denmark[,"lower"]), 
            upper=cbind(Sweden[,"upper"], Denmark[,"upper"]), 
            labeltext=rownames(Sweden),
            legend=c("Sweden", "Denmark"), 
            # Added the clip argument as some of 
            # the Danish CI are way out therer
            clip=c(-.2, .2), 
            # Getting the ticks auto-generate is 
            # a nightmare - it is usually better to 
            # specify them on your own
            xticks=c(-.2, -.1, .0, .1, .2),
            boxsize=0.3,
            col=fpColors(box=c("blue", "darkred")),
            xlab="EQ-5D index",
            new_page=TRUE)

forestplot2(mean=cbind(Sweden[,"coef"], Denmark[,"coef"]), 
            lower=cbind(Sweden[,"lower"], Denmark[,"lower"]), 
            upper=cbind(Sweden[,"upper"], Denmark[,"upper"]), 
            labeltext=rownames(Sweden),
            legend=c("Sweden", "Denmark"), 
            clip=c(-.2, .2), 
            xticks=c(-.2, -.1, .0, .1, .2),
            boxsize=0.3,
            col=fpColors(box=c("blue", "darkred")),
            # Set the different functions
            confintNormalFn=
              list(fpDrawNormalCI, 
                   fpDrawCircleCI, 
                   fpDrawDiamondCI, 
                   fpDrawPointCI),
            pch=13,
            xlab="EQ-5D index",
            new_page=TRUE)

# Changes all to diamonds
confintNormalFn="fpDrawDiamondCI"
 
# The Danish estimates will appear as a circle while 
# Swedes will be as a diamond
confintNormalFn=list(fpDrawDiamondCI, fpDrawCircleCI)
 
# Changes first and third row to diamond + circle
confintNormalFn=list(list(fpDrawDiamondCI, fpDrawCircleCI),
                     list(fpDrawNormalCI, fpDrawNormalCI),
                     list(fpDrawDiamondCI, fpDrawCircleCI),
                     list(fpDrawNormalCI, fpDrawNormalCI))
 
# The same as above but as a matrix diamond + circle
confintNormalFn=rbind(c("fpDrawDiamondCI", "fpDrawCircleCI"),
                      c("fpDrawNormalCI", "fpDrawNormalCI"),
                      c("fpDrawDiamondCI", "fpDrawCircleCI"),
                      c("fpDrawNormalCI", "fpDrawNormalCI"))

forestplot2(mean=cbind(Sweden[,"coef"], Denmark[,"coef"]), 
            lower=cbind(Sweden[,"lower"], Denmark[,"lower"]), 
            upper=cbind(Sweden[,"upper"], Denmark[,"upper"]), 
            labeltext=rownames(Sweden),
            legend=c("Sweden", "Denmark"), 
            legend.pos=list(x=0.8,y=.4),
            legend.gp = gpar(col="#AAAAAA"), 
            legend.r=unit(.1, "snpc"),
            clip=c(-.2, .2), 
            xticks=c(-.2, -.1, .0, .1, .2),
            boxsize=0.3,
            col=fpColors(box=c("blue", "darkred")),
            # Set the different functions
            confintNormalFn=c("fpDrawDiamondCI", "fpDrawCircleCI"),
            xlab="EQ-5D index",
            new_page=TRUE)

grid.newpage()
for(i in 1:5){
  grid.text(sprintf("%d = ", ((i-1)*5+1:5)),
            just="right",
            x=unit(seq(.1, .9, length.out=5), "npc")-unit(3, "mm"), 
            y=unit(rep(seq(.9, .1, length.out=5)[i], times=5), "npc"))
 
  grid.points(x=unit(seq(.1, .9, length.out=5), "npc"), 
              y=unit(rep(seq(.9, .1, length.out=5)[i], times=5), "npc"),
              pch=((i-1)*5+1:5),
              gp=gpar(col="black", fill="blue"))
 
}

fpDrawNormalCI <- function(lower_limit, 
                           estimate, 
                           upper_limit, 
                           size, 
                           y.offset = 0.5, 
                           clr.line, clr.marker,
                           lwd,
                           ...) {
  # Draw the lines if the lower limit is
  # actually below the upper limit
  if (lower_limit < upper_limit){
    # If the limit is outside the 0-1 range in npc-units
    # then that part is outside the box and it should 
    # be clipped (this function adds an arrow to the end
    # of the line)
    clipupper <- 
      convertX(unit(upper_limit, "native"), 
               "npc", 
               valueOnly = TRUE) > 1
    cliplower <- 
      convertX(unit(lower_limit, "native"), 
               "npc", 
               valueOnly = TRUE) < 0
 
    if (clipupper || cliplower) {
      # A version where arrows are added to the part outside 
      # the limits of the graph
      ends <- "both"
      lims <- unit(c(0, 1), c("npc", "npc"))
      if (!clipupper) {
        ends <- "first"
        lims <- unit(c(0, upper_limit), c("npc", "native"))
      }
      if (!cliplower) {
        ends <- "last"
        lims <- unit(c(lower_limit, 1), c("native", "npc"))
      }
      grid.lines(x = lims, 
                 y = y.offset, 
                 arrow = arrow(ends = ends, 
                               length = unit(0.05, "inches")), 
                 gp = gpar(col = clr.line, lwd=lwd))
    } else {
      # Don't draw the line if it's no line to draw
      grid.lines(x = unit(c(lower_limit, upper_limit), "native"), y = y.offset, 
                 gp = gpar(col = clr.line, lwd=lwd))
    }
  }
 
  # If the box is outside the plot the it shouldn't be plotted
  box <- convertX(unit(estimate, "native"), "npc", valueOnly = TRUE)
  skipbox <- box < 0 || box > 1
 
  # Lastly draw the box if it is still there
  if (!skipbox){
    # Convert size into 'snpc'
    if(!is.unit(size)){
      size <- unit(size, "snpc")
    }
 
    # Draw the actual box
    grid.rect(x = unit(estimate, "native"), 
              y = y.offset, 
              width = size, 
              height = size, 
              gp = gpar(fill = clr.marker, 
                        col = clr.marker))
  }
}

# If you don't have devtools install run below line:
install("devtools")
# Then install the Grmd-package by running below code:
devtools::install_github("gforge/Grmd")

---
output: Grmd::docx_document
---

---
title: "A fast-track-publishing demo"
output: 
  Grmd::docx_document:
    fig_caption: TRUE
    force_captions: TRUE
---
 
End section of methods
======================
 
```{r Data_prep, echo=FALSE, message=FALSE, warning=FALSE}
# Moved this outside the document for easy of reading
# I often have those sections in here
source("Setup_and_munge.R")
```
 
```{r Versions}
info <- sessionInfo()
r_ver <- paste(info$R.version$major, info$R.version$minor, sep=".")
```
 
All analyses were performed using R (ver. `r r_ver`)[R Core Team, 2013] and packages rms (ver. `r info$otherPkgs$rms$Version`) [F. Harrell, 2014] for analysis, Gmisc for plot and table output (ver. `r info$otherPkgs$Gmisc$Version`), and knitr (ver `r info$otherPkgs$knitr$Version`) [Xie, 2013] for reproducible research.
 
Results
=======
 
We found `r nrow(melanoma)` patients with malignant melanoma between the years `r paste(range(melanoma$year), collapse=" and ")`. Patients were followed until the end of 1977, the median follow-up time was `r sprintf("%.1f", median(melanoma$time_years))` years (range `r paste(sprintf("%.1f", range(melanoma$time_years)), collapse=" to ")` years). Males were more common than females and had also a higher mortality rate.
 
```{r Table1, results='asis', cache=FALSE}
table_data <- list()
getT1Stat <- function(varname, digits=0){
  getDescriptionStatsBy(melanoma[, varname], melanoma$status, 
                        add_total_col=TRUE,
                        show_all_values=TRUE, 
                        hrzl_prop=TRUE,
                        statistics=FALSE, 
                        html=TRUE, 
                        digits=digits)
}
 
# Get the basic stats
table_data[["Sex"]] <- getT1Stat("sex")
table_data[["Age<sup>&dagger;</sup>"]] <- getT1Stat("age")
table_data[["Ulceration"]] <- getT1Stat("ulcer")
table_data[["Thickness<sup>&Dagger;</sup>"]] <- getT1Stat("thickness", digits=1)
 
# Now merge everything into a matrix
# and create the rgroup & n.rgroup variabels
rgroup <- c()
n.rgroup <- c()
output_data <- NULL
for (varlabel in names(table_data)){
  output_data <- rbind(output_data, table_data[[varlabel]])
  rgroup <- c(rgroup, varlabel)
  n.rgroup <- c(n.rgroup, nrow(table_data[[varlabel]]))
}
 
# Add a column spanner for the death columns
cgroup <- c("", "Death")
n.cgroup <- c(2, 2)
colnames(output_data) <- gsub("[ ]*death", "", colnames(output_data))
 
htmlTable(output_data, align="rrrr",
          rgroup=rgroup, n.rgroup=n.rgroup, 
          rgroupCSSseparator="", 
          cgroup = cgroup,
          n.cgroup = n.cgroup,
          rowlabel="", 
          caption="Baseline characteristics", 
          tfoot="<sup>&dagger;</sup> Age at the time of surgery. <br/><sup>&Dagger;</sup> Tumour thickness, also known as Breslow thickness, measured in mm.", 
          ctable=TRUE)
```
 
Main results
------------
 
```{r C_and_A, results='asis'}
label(melanoma$sex) <- "Sex"
label(melanoma$age) <- "Age"
label(melanoma$ulcer) <- "Ulceration"
label(melanoma$thickness) <- "Breslow thickness"
 
# Setup needed for the rms coxph wrapper
ddist <- datadist(melanoma)
options(datadist = "ddist")
 
# Do the cox regression model 
# for melanoma specific death
msurv <- Surv(melanoma$time_years, melanoma$status=="Melanoma death")
fit <- cph(msurv ~ sex + age + ulcer + thickness, data=melanoma)
 
# Print the model
printCrudeAndAdjustedModel(fit, desc_digits=0,
                           caption="Adjusted and unadjusted estimates for melanoma specific death.",
                           desc_column=TRUE,
                           add_references=TRUE, 
                           ctable=TRUE)
 
pvalues <- 
  1 - pchisq(coef(fit)^2/diag(vcov(fit)), df=1)
```
 
After adjusting for the three variables, age, sex, tumor thickness and ulceration, only the latter two remained significant (p-value `r pvalueFormatter(pvalues["ulcer=Present"], sig.limit=10^-3)` and `r pvalueFormatter(pvalues["thickness"], sig.limit=10^-3)`), see table `r as.numeric(options("table_counter"))-1` and Fig. `r figCapNoNext()`.
 
```{r Regression_forestplot, fig.height=3, fig.width=5, out.height=300, out.width=500, dpi=300, fig.cap=figCapNo("A forest plot comparing the regression coefficients.")}
# The output size can be fixed by out.width=625, out.height=375 but you loose the caption
# I've adjusted the coefficient for age to be by 
forestplotRegrObj(update(fit, .~.-age+I(age/10)), 
                  order.regexps=c("Female", "age", "ulc", "thi"),
                  box.default.size=.25, xlog=TRUE,
                  new_page=TRUE, clip=c(.5, 6), rowname.fn=function(x){
  if (grepl("Female", x))
    return("Female")
 
  if (grepl("Present", x))
    return("Ulceration")
 
  if (grepl("age", x))
    return("Age/10 years")
 
  return(capitalize(x))
})
```

##################
# Knitr settings #
##################
 
knitr::opts_chunk$set(warning=FALSE,
                      message=FALSE,
                      echo=FALSE,
                      dpi=96,
                      fig.width=4, fig.height=4, # Default figure widths
                      dev="png", dev.args=list(type="cairo"), # The png device
                      # Change to dev="postscript" if you want the EPS-files
                      # for submitting. Also remove the dev.args() as the postscript
                      # doesn't accept the type="cairo" argument.
                      error=FALSE)
 
# Evaluate the figure caption after the plot
knitr::opts_knit$set(eval.after='fig.cap')
 
# Use the table counter that the htmlTable() provides
options(table_counter = TRUE)
 
# Use the figCapNo() with roman letters
options(fig_caption_no_roman = TRUE)
 
#################
# Load_packages #
#################
library(rms) # I use the cox regression from this package
library(boot) # The melanoma data set is used in this exampe
library(Gmisc) # Stuff I find convenient
library(Greg) # You need to get this from my GitHub see http://gforge.se/Gmisc
 
##################
# Munge the data #
##################
 
# Here we go through and setup the variables so that
# they are in the proper format for the actual output
 
# Load the dataset - usually you would use read.csv
# or something similar
data("melanoma")
 
# Set time to years instead of days
melanoma$time_years <-
  melanoma$time / 365.25
 
# Factor the basic variables that
# we're interested in
melanoma$status <-
  factor(melanoma$status,
         levels=c(2, 1, 3),
         labels=c("Alive", # Reference
                  "Melanoma death",
                  "Non-melanoma death"))
melanoma$sex <-
  factor(melanoma$sex,
         labels=c("Male", # Reference
                  "Female"))
 
melanoma$ulcer <-
  factor(melanoma$ulcer,
         levels=0:1,
         labels=c("Absent", # Reference
                  "Present"))

knitr::opts_chunk$set(
  warning=FALSE,
  message=FALSE,
  echo=FALSE,
  dpi=96,
  fig.width=4, fig.height=4, # Default figure widths
  dev="png", dev.args=list(type="cairo"), # The png device
  # Change to dev="postscript" if you want the EPS-files
  # for submitting. Also remove the dev.args() as the postscript
  # doesn't accept the type="cairo" argument.
  error=FALSE
)

# Gets the output_format
output_ret_val$post_processor_old <-
  output_ret_val$post_processor
 
# Wraps the old with the new post-processor
output_ret_val$post_processor <-
  post_processor <- function(metadata, input_file, output_file, clean, verbose,
                             old_post_processor =  output_ret_val$post_processor_old) {
    # Call the original post-processor in order to limit the changes that this function
    # has on the original functionality
    output_file <-
      old_post_processor(
        metadata = metadata,
        input_file = input_file,
        output_file = output_file,
        clean = clean,
        verbose = verbose
      )
 
    # read the output file
    output_str <- readLines(output_file, warn = FALSE, encoding = "UTF-8")
 
    # Annoyingly it seems that Libre Office currently
    # 'forgets' the margin properties of the headers,
    # we therefore substitute these with a element specific
    # style option that works. Perhaps not that pretty but
    # it works and can be tweaked for most things.
    output_str <-
      gsub(
        paste0('<h([0-9]+)',
               '(| ',
               '([ ]*class="[^"]+"',
               '|[ ]*id="[^"]+")+',
               ')[ ]*>'),
        paste0('<h\\1\\2 style="', other_h_style, '">'),
        gsub(
          paste0('<h1+',
                 '(| ',
                 '([ ]*class="[^"]+"',
                 '|[ ]*id="[^"]+")+',
                 ')[ ]*>'),
          paste0('<h1\\1 style="', h1_style, '">'),
          output_str
        )
      )
 
    writeLines(output_str, output_file, useBytes = TRUE)
    return(output_file)
  }

prCaptionFix <- function(outFile){
  # Encapsulate within a try since there is a high risk of unexpected errors
  tryCatch({
    # Open and read the file generated by pandoc
    tmp <- XML::htmlParse(outFile, encoding="utf-8", replaceEntities = FALSE)
 
    # The caption-less images are currently located under a p-element instead of a div
    caption_less_images <- xpathApply(tmp, "/html/body//p/img")
    for (i in 1:length(caption_less_images)){
      old_node <- xmlParent(caption_less_images[[i]])
      img_clone <- xmlClone(caption_less_images[[i]])
      new_node <- newXMLNode("div",
                             img_clone,
                             newXMLNode("p",
                                        xmlAttrs(img_clone)["title"],
                                        attrs=c(class="caption")),
                             attrs=c(class="figure"))
      replaceNodes(oldNode = old_node,
                   newNode = new_node)
    }
 
    saveXML(tmp, encoding = "utf-8", file=outFile)
  }, error=function(err)warning("Could not force captions - error occurred: '", err, "'"))
 
  return(outFile)
}

---
output: word_document
---
 
```{r, results='asis'}
mx <- matrix(1:6, ncol=3)
colnames(mx) <- c("First", "Second", "Third")
knitr::kable(mx, align=c("l", "c", "r"), format="pandoc", caption="Test table")
```

library(caret)
train_no <- createDataPartition(1:nrow(my_dataset), 
                                list = FALSE,
                                p = .7)
train <- my_dataset[train_no, ]
test <- my_dataset[-train_no, ]
 
# A list with all the fits that are later to be benchmarked
fits <- list(eq5d = list(),
             eq_vas = list())
 
# The rms-setup
library(rms)
ddist <- datadist(train)
options("datadist" = "ddist")

idx_model <- ols(eq5d1 ~ rcs(Age, 3) + 
                   Sex * Charnley_class + 
                   rcs(eq5d0, 3)+rcs(pain0, 3),
             data=train, x=TRUE, y=TRUE)
anova(idx_model, ss=FALSE)

lm1 <- lm(eq5d1 ~ Age + 
            Sex * Charnley_class + 
            ns(eq5d0, 3)+ns(pain0, 3),
          data=train)
lm2 <- lm(eq5d1 ~ ns(Age, 3) + 
            Sex * Charnley_class + 
            ns(eq5d0, 3)+ns(pain0, 3),
          data=train)
anova(lm1, lm2)

#' A simple function for updating the formula and extracting
#' the information criteria
#' 
#' @param no A number that is used together with the add_var_str
#' @param fit A regression fit that is used for the update
#' @param rm_var The variable that is to be substituted
#' @param add_var_str A sprintf() string that accepts the no
#'  parameter for each update
#' @param ic_fn The information criteria function (AIC/BIC)
getInfCrit <- function(no, fit, rm_var, add_var_str, ic_fn) {
  new_var <- sprintf(add_var_str, no)
  updt_frml <- as.formula(sprintf(".~.-%s+%s", 
                                  rm_var,
                                  new_var))
  ret <- ic_fn(update(fit, updt_frml))
  names(ret) <- new_var
  return(ret)}
 
# We start with a model where the other splines 
# have been AIC-selected
idx_model <- ols(eq5d1 ~ rcs(Age, 3) + 
                   Sex * Charnley_class + 
                   rcs(eq5d0, 8)+rcs(pain0, 6),
             data=train, x=TRUE, y=TRUE)
 
sapply(3:9, getInfCrit, fit = idx_model,
  rm_var = "rcs(Age, 3)", add_var_str = "rcs(Age, %d)", ic_fn=AIC)
# rcs(Age, 3) rcs(Age, 4) rcs(Age, 5) rcs(Age, 6) rcs(Age, 7) rcs(Age, 8) rcs(Age, 9) 
#  -33678.89   -33674.68   -33686.30   -33686.93   -33685.95   -33686.73   -33699.37 
 
fits$eq5d[["RCS with AIC"]] <- update(idx_model, .~.-rcs(Age, 3)+rcs(Age, 5))

vas_model <- ols(eq_vas1 ~ Sex * Charnley_cat + Sex + rcs(Age, 3) + 
                   rcs(eq_vas0, 3) + OpNr + rcs(pain0, 3),
                 data=train, x=TRUE, y=TRUE)
sapply(3:9, getInfCrit, fit = vas_model,
  rm_var = "rcs(Age, 3)", add_var_str = "rcs(Age, %d)", ic_fn=AIC)
# rcs(Age, 3) rcs(Age, 4) rcs(Age, 5) rcs(Age, 6) rcs(Age, 7) rcs(Age, 8) rcs(Age, 9) 
#    166615.6    166619.8    166600.2    166600.1    166602.0    166603.0    166596.7 
fits$eq_vas[["RCS with AIC"]] <- update(vas_model, .~.-rcs(Age, 3)+rcs(Age, 5))

idx_model <- ols(eq5d1 ~ rcs(Age, 3) + 
                   Sex * Charnley_cat + 
                   rcs(eq5d0, 3)+rcs(pain0, 3),
                 data=train, x=TRUE, y=TRUE)
 
sapply(3:9, getInfCrit, fit = idx_model,
  rm_var = "rcs(Age, 3)", add_var_str = "rcs(Age, %d)", ic_fn=BIC)
# rcs(Age, 3) rcs(Age, 4) rcs(Age, 5) rcs(Age, 6) rcs(Age, 7) rcs(Age, 8) rcs(Age, 9) 
#   -33486.35   -33474.16   -33477.95   -33470.69   -33462.17   -33455.28   -33459.98 
fits$eq5d[["RCS with BIC"]] <- idx_model
 
vas_model <- ols(eq_vas1 ~ rcs(Age, 3) + 
                   Sex * Charnley_cat + 
                   rcs(eq_vas0, 3) + OpNr + rcs(pain0, 3),
                 data=train, x=TRUE, y=TRUE)
 
sapply(3:9, getInfCrit, fit = vas_model,
  rm_var = "rcs(Age, 3)", add_var_str = "rcs(Age, %d)", ic_fn=BIC)
# rcs(Age, 3) rcs(Age, 4) rcs(Age, 5) rcs(Age, 6) rcs(Age, 7) rcs(Age, 8) rcs(Age, 9) 
#    166725.7    166737.8    166726.0    166733.8    166743.5    166752.4    166754.0 
fits$eq_vas[["RCS with BIC"]] <- vas_model

# Use the same setting model as used in the RCS
vars <- attr(terms(fits$eq5d[["RCS with AIC"]]), "term.labels")
rm_var <- vars[grep("Age", vars, fixed = TRUE)]
idx_model <- update(fits$eq5d[["RCS with AIC"]], 
                    sprintf(".~.-%s+bs(Age, 3)", rm_var))
sapply(3:9, getInfCrit, fit = idx_model,
  rm_var = "bs(Age, 3)", add_var_str = "bs(Age, %d)", ic_fn=AIC)
# bs(Age, 3) bs(Age, 4) bs(Age, 5) bs(Age, 6) bs(Age, 7) bs(Age, 8) bs(Age, 9) 
#  -33669.07  -33683.35  -33680.55  -33683.44  -33683.03  -33681.79  -33685.55 
# Chose 6 knots for illustration as it otherwise be the
# same as the BIC model - not that interesting
fits$eq5d[["BS with AIC"]] <- 
  update(idx_model, .~.-bs(Age, 3)+bs(Age, 6))
 
vars <- attr(terms(fits$eq5d[["RCS with BIC"]]), "term.labels")
rm_var <- vars[grep("Age", vars, fixed = TRUE)]
idx_model <- update(fits$eq5d[["RCS with BIC"]], 
                    sprintf(".~.-%s+bs(Age, 3)", rm_var))
sapply(3:9, getInfCrit, fit = idx_model,
  rm_var = "bs(Age, 3)", add_var_str = "bs(Age, %d)", ic_fn=BIC)
# bs(Age, 3) bs(Age, 4) bs(Age, 5) bs(Age, 6) bs(Age, 7) bs(Age, 8) bs(Age, 9) 
#  -33468.29  -33475.09  -33464.40  -33459.42  -33451.12  -33442.38  -33438.71 
fits$eq5d[["BS with BIC"]] <- 
  update(idx_model, .~.-bs(Age, 3)+bs(Age, 4))
 
vars <- attr(terms(fits$eq_vas[["RCS with AIC"]]), "term.labels")
rm_var <- vars[grep("Age", vars, fixed = TRUE)]
vas_model <- update(fits$eq_vas[["RCS with AIC"]], 
                    sprintf(".~.-%s+bs(Age, 3)", rm_var))
sapply(3:9, getInfCrit, fit = vas_model,
  rm_var = "bs(Age, 3)", add_var_str = "bs(Age, %d)", ic_fn=AIC)
# bs(Age, 3) bs(Age, 4) bs(Age, 5) bs(Age, 6) bs(Age, 7) bs(Age, 8) bs(Age, 9) 
#   166640.3   166617.2   166621.1   166612.9   166613.2   166614.8   166615.0 
fits$eq_vas[["BS with AIC"]] <- update(vas_model, .~.-bs(Age, 3)+bs(Age, 6))
 
vars <- attr(terms(fits$eq_vas[["RCS with BIC"]]), "term.labels")
rm_var <- vars[grep("Age", vars, fixed = TRUE)]
vas_model <- update(fits$eq_vas[["RCS with BIC"]], 
                    sprintf(".~.-%s+bs(Age, 3)", rm_var))
sapply(3:9, getInfCrit, fit = vas_model,
  rm_var = "bs(Age, 3)", add_var_str = "bs(Age, %d)", ic_fn=BIC)
# bs(Age, 3) bs(Age, 4) bs(Age, 5) bs(Age, 6) bs(Age, 7) bs(Age, 8) bs(Age, 9) 
#   166750.4   166735.1   166746.9   166746.5   166754.7   166764.2   166772.2 
fits$eq_vas[["BS with BIC"]] <- update(vas_model, .~.-bs(Age, 3)+bs(Age, 4))

# Use the same setting model as used in the RCS
vars <- attr(terms(fits$eq5d[["RCS with AIC"]]), "term.labels")
rm_var <- vars[grep("Age", vars, fixed = TRUE)]
idx_model <- update(fits$eq5d[["RCS with AIC"]], 
                    sprintf(".~.-%s+poly(Age, 2)", rm_var))
sapply(2:9, getInfCrit, fit = idx_model,
  rm_var = "poly(Age, 2)", add_var_str = "poly(Age, %d)", ic_fn=AIC)
# poly(Age, 2) poly(Age, 3) poly(Age, 4) poly(Age, 5) poly(Age, 6) poly(Age, 7) poly(Age, 8) poly(Age, 9) 
#    -33669.58    -33669.07    -33680.10    -33678.83    -33681.82    -33681.89    -33680.35    -33680.17 
fits$eq5d[["Polynomial with AIC"]] <- 
  update(idx_model, .~.-poly(Age, 2)+poly(Age, 6))
 
vars <- attr(terms(fits$eq5d[["RCS with BIC"]]), "term.labels")
rm_var <- vars[grep("Age", vars, fixed = TRUE)]
idx_model <- update(fits$eq5d[["RCS with BIC"]], 
                    sprintf(".~.-%s+poly(Age, 2)", rm_var))
sapply(2:9, getInfCrit, fit = idx_model,
  rm_var = "poly(Age, 2)", add_var_str = "poly(Age, %d)", ic_fn=BIC)
# poly(Age, 2) poly(Age, 3) poly(Age, 4) poly(Age, 5) poly(Age, 6) poly(Age, 7) poly(Age, 8) poly(Age, 9) 
#    -33476.79    -33468.29    -33471.83    -33462.59    -33457.76    -33450.37    -33440.97    -33432.99 
fits$eq5d[["Polynomial with BIC"]] <- idx_model
 
vars <- attr(terms(fits$eq_vas[["RCS with AIC"]]), "term.labels")
rm_var <- vars[grep("Age", vars, fixed = TRUE)]
vas_model <- update(fits$eq_vas[["RCS with AIC"]], 
                    sprintf(".~.-%s+poly(Age, 2)", rm_var))
sapply(2:9, getInfCrit, fit = vas_model,
  rm_var = "poly(Age, 2)", add_var_str = "poly(Age, %d)", ic_fn=AIC)
# poly(Age, 2) poly(Age, 3) poly(Age, 4) poly(Age, 5) poly(Age, 6) poly(Age, 7) poly(Age, 8) poly(Age, 9) 
#     166638.4     166640.3     166622.3     166623.9     166615.7     166616.8     166617.2     166617.5 
fits$eq_vas[["Polynomial with AIC"]] <- 
  update(vas_model, .~.-poly(Age, 2)+poly(Age, 6))
 
vars <- attr(terms(fits$eq_vas[["RCS with BIC"]]), "term.labels")
rm_var <- vars[grep("Age", vars, fixed = TRUE)]
vas_model <- update(fits$eq_vas[["RCS with BIC"]], 
                    sprintf(".~.-%s+poly(Age, 2)", rm_var))
sapply(2:9, getInfCrit, fit = vas_model,
  rm_var = "poly(Age, 2)", add_var_str = "poly(Age, %d)", ic_fn=BIC)
# poly(Age, 2) poly(Age, 3) poly(Age, 4) poly(Age, 5) poly(Age, 6) poly(Age, 7) poly(Age, 8) poly(Age, 9) 
#     166740.6     166750.4     166740.2     166749.7     166749.3     166758.3     166766.6     166774.7 
fits$eq_vas[["Polynomial with BIC"]] <- 
  update(vas_model, .~.-poly(Age, 2)+poly(Age, 4))

library(mfp)
 
# We will use the simple BIC models and
# instead of rcs() that is not available
# for mfp we use ns() from the splines package
fits$eq5d[["MFP"]] <- 
  mfp(eq5d1 ~ fp(Age) + 
        Sex * Charnley_class + 
        ns(eq5d0, 3)+ns(pain0, 3),
      data=train)
fits$eq_vas[["MFP"]] <- 
  mfp(eq_vas1 ~ fp(Age) + 
        Sex * Charnley_class + 
        ns(eq_vas0, 3)+ns(pain0, 3),
      data=train)

library(mgcv)
 
fits$eq5d[["GAM thin plate"]] <- 
  gam(eq5d1 ~ s(Age, bs="tp") + 
        Sex * Charnley_class + 
        ns(eq5d0, 3) + ns(pain0, 3),
      data=train)
fits$eq_vas[["GAM thin plate"]] <- 
  gam(eq_vas1 ~ s(Age, bs="tp") + 
        Sex * Charnley_class + 
        ns(eq_vas0, 3) + ns(pain0, 3), 
      data=train)
 
fits$eq5d[["GAM cubic regression"]] <-
  update(fits$eq5d[["GAM thin plate"]], 
         .~.-s(Age, bs="tp")+s(Age, bs="cr"))
 
fits$eq_vas[["GAM cubic regression"]] <- 
  update(fits$eq_vas[["GAM thin plate"]], 
         .~.-s(Age, bs="tp")+s(Age, bs="cr"))
 
 
fits$eq5d[["GAM P-splines"]] <-
  update(fits$eq5d[["GAM thin plate"]], 
         .~.-s(Age, bs="tp")+s(Age, bs="ps"))
 
fits$eq_vas[["GAM P-splines"]] <- 
  update(fits$eq_vas[["GAM thin plate"]], 
         .~.-s(Age, bs="tp")+s(Age, bs="ps"))

rmse <- function(fit, newdata, outcome_var){
  pred <- predict(fit, newdata=newdata)
  sqrt(mean((newdata[, outcome_var]-pred)^2, na.rm=TRUE))
}
mape <- function(fit, newdata, outcome_var){
  pred <- predict(fit, newdata=newdata)
  mean(abs(newdata[, outcome_var]-pred)/mean(newdata[, outcome_var], na.rm=TRUE)*100, na.rm=TRUE)
}

crossValidateInParallel <- function(fit, df, 
                                    outcome_var, 
                                    k=10, tail_prop=.15){
  df$central <- with(df, Age >= quantile(Age, probs=tail_prop) & 
                       Age <= quantile(Age, probs=1-tail_prop))
  df$cv <- rep(1:k, length.out=nrow(df))
 
  cv_internal_fn <- function(x, cv_fit,
                             df, outcome_var){
    lc_train <- subset(df, cv != x)
    lc_test <- subset(df, cv == x)
 
    # In the original version I had a BIC/AIC optimizing
    # function that worked with the cross-validation
    # Here, we'll keep it simple and just use the previously
    # chosen functions
    cv_fit <- update(fit, data=lc_train)
 
    return(c(Main_RMSE = 
               rmse(cv_fit, 
                    newdata=lc_test, 
                    outcome_var=outcome_var),
             Central_RMSE = 
               rmse(cv_fit, 
                    newdata=subset(lc_test, central == TRUE), 
                    outcome_var=outcome_var),
             Peripheral_RMSE = 
               rmse(cv_fit, 
                    newdata=subset(lc_test, central ==  FALSE), 
                    outcome_var=outcome_var),
             Main_MAPE = 
               mape(cv_fit, 
                    newdata=lc_test, 
                    outcome_var=outcome_var),
             Central_MAPE = 
               mape(cv_fit, 
                    newdata=subset(lc_test, central == TRUE), 
                    outcome_var=outcome_var),
             Peripheral_MAPE = 
               mape(cv_fit, 
                    newdata=subset(lc_test, central ==  FALSE), 
                    outcome_var=outcome_var)))
    }
 
  # It is convenient to use the detectCores() function in
  # order to use the machines full capacity. Subtracting
  # 1 is also preferable as it prohibits the computer from
  # stopping other tasks, i.e. you can keep surfing the web :-)
  cl <- makeCluster(mc <- getOption("cl.cores", ifelse(detectCores() <= 1,
                                                       1,
                                                       detectCores() - 1)))
  # In Windows each cores starts out fresh and we therefore need
  # to export the functions, data etc so that they can access
  # it as expected or you will get nasty errors
  clusterEvalQ(cl, library(mfp))
  clusterEvalQ(cl, library(mgcv))
  clusterEvalQ(cl, library(rms))
  clusterEvalQ(cl, library(splines))
  clusterEvalQ(cl, library(stringr))
  clusterExport(cl, c("rmse", "mape"))
 
  res <- parallel::parLapply(1:k,
                             cl=cl,
                             fun=cv_internal_fn,
                             outcome_var=outcome_var,
                             cv_fit = fit,
                             df=df)
 
  stopCluster(cl)
  res <- as.data.frame(Gmisc::mergeLists(lapplyOutput=res))
  ret <- colMeans(res)
  attr(ret, "raw") <- res
  return(ret)
}