Nothing
# Copyright (c) 2018, Adrian Dusa
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, in whole or in part, are permitted provided that the
# following conditions are met:
# * Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
# * Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
# * The names of its contributors may NOT be used to endorse or promote products
# derived from this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
# DISCLAIMED. IN NO EVENT SHALL ADRIAN DUSA BE LIABLE FOR ANY
# DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
# ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
`sop` <- function(expression, snames = "", use.tilde = FALSE, noflevels) {
syscalls <- unlist(lapply(sys.calls(), deparse))
if (any(withdata <- grepl("with\\(", syscalls))) {
snames <- get(unlist(strsplit(gsub("with\\(", "", syscalls), split = ","))[1], envir = length(syscalls) - which(withdata))
}
snames <- splitstr(snames)
multivalue <- any(grepl("[{|}]", expression))
if (multivalue) {
expression <- toupper(gsub("[*]", "", expression))
verify.multivalue(expression, snames = snames, noflevels = noflevels)
}
sl <- ifelse(identical(snames, ""), FALSE, ifelse(all(nchar(snames) == 1), TRUE, FALSE))
getbl <- function(expression) {
bl <- splitMainComponents(gsub("[[:space:]]", "", expression))
bl <- splitBrackets(bl)
bl <- removeSingleStars(bl)
bl <- splitPluses(bl)
blu <- unlist(bl)
bl <- splitStars(bl, ifelse((sl | any(hastilde(blu) & !tilde1st(blu))) & !grepl("[*]", expression) & !multivalue, "", "*"))
bl <- solveBrackets(bl)
bl <- simplifyList(bl)
return(bl)
}
bl <- list()
if (any(hastilde(expression))) {
use.tilde <- TRUE
}
for (i in seq(length(expression))) {
bl <- c(bl, lapply(getbl(expression[i]), function(x) {
x <- unlist(x)
if (multivalue) {
outx <- toupper(curlyBrackets(x, outside=TRUE))
inx <- curlyBrackets(x)
x <- paste(outx, "{", inx, "}", sep = "")
}
x <- cx <- unique(unlist(x))
tx <- which(hastilde(x))
if (!multivalue) {
if (any(tx)) {
x <- notilde(x)
uptx <- x[tx] %in% toupper(x)
lotx <- x[tx] %in% tolower(x)
x[tx[uptx]] <- tolower(x[tx[uptx]])
x[tx[lotx]] <- toupper(x[tx[lotx]])
}
}
cx <- cx[!duplicated(x)]
if (any(duplicated(toupper(notilde(cx))))) {
return(NULL)
}
else {
if (use.tilde) {
tx <- hastilde(cx)
x <- notilde(cx)
lotx <- x %in% tolower(x)
tx[lotx] <- !tx[lotx]
x <- toupper(x)
x[tx] <- paste("~", x[tx], sep = "")
cx <- x
}
return(cx)
}
}))
}
bl <- unique(bl[!unlist(lapply(bl, is.null))])
redundants <- logical(length(bl))
if (length(bl) > 1) {
for (i in seq(length(bl) - 1)) {
for (j in seq(i + 1, length(bl))) {
if (all(bl[[i]] %in% bl[[j]]) & length(bl[[i]]) < length(bl[[j]])) {
redundants[j] <- TRUE
}
if (all(bl[[j]] %in% bl[[i]]) & length(bl[[j]]) < length(bl[[i]])) {
redundants[i] <- TRUE
}
}
}
}
bl <- bl[!redundants]
if (length(bl) > 0) {
bl <- bl[order(unlist(lapply(bl, length)))]
}
if (!identical(snames, "")) {
bl <- unique(unlist(lapply(bl, function(x) {
paste(x[order(match(toupper(notilde(x)), toupper(snames)))], collapse = "*")
})))
if (any(blsn <- is.element(toupper(notilde(bl)), toupper(snames)))) {
bl[blsn] <- bl[blsn][order(match(toupper(notilde(bl[blsn])), toupper(snames)))]
}
}
else {
bl <- unique(unlist(lapply(bl, function(x) paste(x[order(notilde(x))], collapse = "*"))))
}
if (multivalue) {
blt <- as.vector(apply(translate(bl, snames = snames, noflevels = noflevels), 1, function(x) {
x <- x[x >= 0]
return(as.vector(paste(names(x), "{", x, "}", sep = "", collapse = "*")))
}))
if (identical(bl, blt)) {
if (sl) {
bl <- gsub("[*]", "", bl)
}
return(paste(bl, collapse = " + "))
}
return(Recall(paste(blt, collapse = " + ")))
}
else {
if (sl) {
bl <- gsub("[*]", "", bl)
}
return(paste(bl, collapse = " + "))
}
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.