#' End Sentence
#'
#' @param string Input string
#'
#' @return `string`, punctuated with a final full stop (period).`
#'
#' @examples {
#' EndSentence("Hello World")
#' # "Hello World."
#' }
#'
#' @author Martin R. Smith
#' @export
EndSentence <- function (string) {
ret <- gsub("\\s*\\.?\\s*\\.$", ".", paste0(string, '.'), perl=TRUE)
ret <- gsub("(\\.[\"'])\\.$", "\\1", ret, perl=TRUE)
ret <- gsub("([!\\?])\\.$", "\\1", ret, perl=TRUE)
ret
}
#' Decode MorphoBank text
#'
#' Converts strings from MorphoBank notes into a format compatible with Latex / bookdown
#'
#' @param string String to process
#'
#' @return A string with new lines and punctuation reformatted
#' @export
#' @author Martin R. Smith
#'
MorphoBankDecode <- function (string) {
string <- gsub("^n", " \n", string, fixed=TRUE)
string <- gsub("''", "'", string, fixed=TRUE)
string <- gsub(" - ", " -- ", string, fixed=TRUE)
string <- gsub("(\\d)\\-(\\d)", "\\1--\\2", string, perl=TRUE)
string <- gsub("(\\d) ?um\\b", "\\1 \u{03BC}m", string, perl=TRUE)
string <- gsub(" [recoded as neomorphic]",
" Inapplicable tokens in this neomorphic character have been replaced with the absent token, following @Brazeau2018", string, fixed=TRUE)
# Return:
string
}
#' Print States
#'
#' Prints a summary of the character states for a given character
#'
#' @template statesParam
#'
#' @return Text listing the states, ready for inclusion in a markdown source document
#'
#' @author Martin R. Smith
#' @export
PrintStates <- function (states) {
states <- gsub("^'(.*)'$", "\\1", states)
tokens <- seq_along(states) - 1L
if (states[1] == "") {
states <- states[-1]
tokens <- tokens[-1]
transformational <- TRUE
} else {
transformational <- FALSE
}
cat(paste0(" > ", tokens, ": ", states, " \n"))
cat("> ", if (transformational) "Transformational" else "Neomorphic", "character. \n>\n")
}
#' Print State Notes
#'
#' @param notes Named character vector, with names corresponding to terminal taxa,
#' and values corresponding to character coding notes for each taxon in turn.
#' This matches the format given by `ReadNotes(filename)[[character_number]][[2]]`.`
#' @param taxaNames Character vector specifying names of taxa.
#' @param taxaItalic Character vector corresponding to taxaNames, but using
#' `_`underscores`_` to denote italic text where required.
#' @param charId Character or integer identifying the character, for use in the
#' resultant div's ID attribute.
#' @template FormatParam
#'
#' @return Text listing the character coding notes for each taxon, ready for inclusion in a markdown source document
#'
#' @author Martin R. Smith
#' @export
#'
#' @examples {
#' \dontrun{
#' notes <- ReadNotes(filename)
#' character_1_notes <- notes[[1]]
#' cat("Character 1")
#'
#' PrintStateNotes(character_1_notes[[2]])
#' }
#' }
PrintStateNotes <- function (notes, taxaNames=NULL, taxaItalic=taxaNames,
charId=character(0), Format=I) {
PrintThisNote <- function (note) {
afflictedTaxa <- names(note)[note]
if (is.null(taxaNames)) {
taxaNames <- taxaItalic <- afflictedTaxa
}
master <- afflictedTaxa[1]
cat(paste0("<div class='state-note' id='", master, "-coding-", charId, "'><span class='state-note-taxon'>",
paste(taxaItalic[taxaNames %in% afflictedTaxa], collapse=', '),
":</span> ", Format(notes[master]), "</div> \n \n"))
}
DuplicateOf <- function (x) {
duplicates <- duplicated(x)
masters <- x[!duplicates]
vapply(masters, function (d) x == d, logical(length(x)))
}
if (length(notes) > 0) {
cat(' \n<div class="state-notes">')
}
if (length(notes) == 1) {
onlyOne <- TRUE
names(onlyOne) <- names(notes)
PrintThisNote(onlyOne)
} else {
notes <- notes[order(names(notes))]
duplicates <- DuplicateOf(toupper(notes))
apply(duplicates, 2, PrintThisNote)
}
if (length(notes) > 0) {
cat('</div> \n \n')
}
}
#' Print Naughty Inapplicables
#'
#' Prints a warning message when an inapplicable token is found in a neomorphic character.
#'
#' @template statesParam
#'
#' @return A warning message for inclusion in a markdown documnet.
#'
#' @author Martin R. Smith
#' @export
PrintNaughtyInapplicables <- function (states) {
if (any(states == '-'))
cat(" \n Oh dear! <mark>**You included the inapplicable token in a neomorphic character!**</mark>",
" \n That's unlikely to be a good idea:",
" see Brazeau, Smith & Guillerme (2019, Systematic Biology).",
" \n Unless you are very sure that you understand the consequences, ",
"you should mark the character as Transformational by setting State 0 to",
"`[Transformational character]`, or re-code: \n\n - ",
paste(names(states[states == '-']), collapse=" \n - "))
}
#' Link to MorphoBank project
#'
#' @param id Integer corresponding to the project's MorphoBank identifier.
#' A global default can be set using `options(MorphoBankProject=1234)`.
#' @param linkText Text to appear in link, once project is live.
#' @param checkAccess Logical specifying whether to display a notice if the
#' project is not yet available to the public.
#'
#' @return `MorphoLink()` returns text providing a link to the project,
#' or if the project is not yet publicly available,
#' a note instructing password holders how to log in.
#' @export
MorphoLink <- function (id = getOption('MorphoBankProject'),
linkText = paste('project', id),
checkAccess = TRUE) {
taxaRoot <- "http://morphobank.org/index.php/Projects/Taxa/project_id/"
linkStatus <- ifelse(checkAccess,
attr(curlGetHeaders(paste0(taxaRoot, id), verify = FALSE), 'status'),
200)
if (linkStatus == 200) {
paste0('[', linkText, '](https://morphobank.org/permalink/?P', id, ')')
} else {
paste("<mark>[This dataset has not yet been released to the public.",
"If you have been given a password, access the dataset by",
"[logging in to MorphoBank](https://morphobank.org/index.php/LoginReg/form)",
"using the project ID `", id,
"` as your e-mail address, and the password you have been given.]</mark>")
}
}
#' Print character heading
#'
#' Prints a character heading using markdown syntax at an appropriate level in
#' the hierarchy.
#'
#' @param char Character string specifying the definition of the character
#' @param charNo Character string identifying the character's number
#' @param prevElements,thisElements,nextElements Character description,
#' decomposed into its constituent hierarchichal elements
#' @param forceDisplay Character vector specifying character descriptions to always
#' print as a header when an exact match is encountered.
#' @template FormatParam
#'
#' @return A heading for the character in markdown format
#' @author Martin R. Smith
#' @export
#'
#' @examples {
#' PrintCharacterHeading("Tail: Colour", 1, "NONE",
#' c("Tail", "Colour"), c("Tail", "Colour", "Patterning"))
#' }
#'
#'
PrintCharacterHeading <- function (char, charNo, prevElements='*NONE*',
thisElements=strsplit(char, ": ")[[1]],
nextElements='*NONE*',
forceDisplay = character(0),
Format = I) {
thisDepth <- length(thisElements)
nextDepth <- length(nextElements)
Header <- function (level, content) paste0(" \n", paste0(rep('#', level), collapse=''), " ", content, " \n")
PrintDivision <- function (parts) cat(Header(2L, paste(
Format(thisElements[1:parts]), collapse=': ')))
PrintCharacter <- function () {
cat(Header(3L, paste0("[", charNo, "] ", paste0(Format(
thisElements[if(thisDepth < 4) thisDepth else 3:thisDepth]),
collapse=': '), " {-}")))
}
PrintSoloCharacter <- function () {
cat(Header(2L, paste0(paste(
Format(thisElements), collapse=': ')," [", charNo, "] ")))
}
if ( # Reasons to print a heading
(char %in% forceDisplay ||
thisElements[1] != prevElements[1])
) {
if ( # Reasons to print a Solo character
(thisElements[1] != nextElements[1] &&
thisElements[1] != prevElements[1]) ||
(thisDepth == 2L && nextDepth > 1L &&
prevElements[1] == thisElements[1] &&
nextElements[1] == thisElements[1]) ||
(thisDepth == 1L && nextDepth > 1L &&
nextElements[1] == thisElements[1])
) {
PrintSoloCharacter()
}
else if ( # Reasons to print a top-level heading
thisDepth == 1L ||
(nextDepth > 1L && (thisElements[2] != nextElements[2]))
) {
PrintDivision(1)
PrintCharacter()
} else {
PrintDivision(2)
PrintCharacter()
}
} else { # Just print the character
PrintCharacter()
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.