Nothing
# Copyright (c) 2016 - 2020, 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.
library(shiny)
library(QCA)
library(admisc)
library(tools)
library(venn)
setwd(Sys.getenv("userwd"))
options(help_type = "html")
listFiles <- function(dirpath, filetype = "*") {
result <- list(dirs = NULL, files = NULL, filepath = as.matrix(filepath), ok = oktoset)
found <- list.files(dirpath)
temp <- toupper(found)
found <- found[match(sort(temp), temp)]
if (length(found) > 0) {
isdir <- sapply(found, function(x) file_test("-d", file.path(dirpath, x)))
if (any(isdir)) {
result$dirs <- found[isdir]
}
if (any(!isdir)) {
if (filetype != "*") {
extensions <- unlist(lapply(strsplit(found, split="[.]"), "[", 2))
found <- found[which(toupper(extensions) == toupper(filetype))]
if (length(found) > 0) {
result$files <- found
}
}
else {
result$files <- found[!isdir]
}
}
result$dirs <- as.list(result$dirs)
result$files <- as.list(result$files)
}
resfilename <- ""
if (!identical(filepath, "")) {
if (file_test("-f", filepath)) {
extension <- file_ext(basename(filepath))
resfilename <- gsub("[[:space:]]", "_", file_path_sans_ext(basename(filepath)))
if (possibleNumeric(substr(resfilename, 1, 1))) {
resfilename <- paste("x", resfilename, sep="")
}
}
}
result$filename <- resfilename
result$extension <- extension
result$wd <- getwd()
return(result)
}
infobjs <- function(env, objs, scrollvh) {
misscroll <- missing(scrollvh)
toreturn <- list(data = NULL, tt = NULL, qmc = NULL)
if (length(objs) > 0) {
objs <- unlist(lapply(mget(objs, env), function(x) {
if (is.data.frame(x)) {
return(1)
}
else if (is(x, "QCA_tt")) {
return(2)
}
else if (is(x, "QCA_min")) {
return(3)
}
else {
return(0)
}
}))
if (any(objs == 1)) {
toreturn$data <- lapply(names(objs[objs == 1]), function(n) {
x <- env[[n]]
dscrollvh <- c(1, 1)
if (!misscroll) {
if (is.element(n, names(scrollvh))) {
dscrollvh <- scrollvh[[n]]
}
}
nrowd <- nrow(x)
ncold <- ncol(x)
srow <- min(dscrollvh[1], nrowd - min(nrowd, visiblerows) + 1)
scol <- min(dscrollvh[2], ncold - min(ncold, visiblecols) + 1)
erow <- min(srow + visiblerows - 1, nrowd)
ecol <- min(scol + visiblecols - 1, ncold)
list(
nrows = nrowd,
ncols = ncold,
rownames = as.list(rownames(x)),
colnames = as.list(colnames(x)),
numerics = as.list(as.vector(unlist(lapply(x, admisc::possibleNumeric)))),
calibrated = as.list(as.vector(unlist(lapply(x, function(x) {
all(na.omit(x) >= 0 & na.omit(x) <= 1)
})))),
binary = as.list(as.vector(unlist(lapply(x, function(x) all(is.element(x, 0:1)))))),
scrollvh = c(srow, scol) - 1,
theData = unname(as.list(x[seq(srow, erow), seq(scol, ecol), drop = FALSE])),
dataCoords = paste(srow, scol, erow, ecol, ncol(x), sep = "_")
)
})
names(toreturn$data) <- names(objs[objs == 1])
}
if (any(objs == 2)) {
toreturn$tt <- lapply(mget(names(objs[objs == 2]), env), function(x) {
components <- c("indexes", "noflevels", "cases", "options", "colnames", "numerics")
x$indexes <- x$indexes - 1
cnds <- x$options$conditions
if (x$options$use.letters) {
cnds <- LETTERS[seq(length(cnds))]
}
x$options$outcome <- list(notilde(x$options$outcome))
if (length(x$options$incl.cut) == 1) {
x$options$incl.cut <- list(x$options$incl.cut)
}
if (length(cnds) <= 7) {
x$id <- apply(x$tt[, cnds], 1, function(x) {
ifelse(any(x == 1), paste(which(x == 1), collapse=""), "0")
})
components <- c(components, "id", "tt")
}
x$colnames <- colnames(x$initial.data)
x$numerics <- as.vector(unlist(lapply(x$initial.data, admisc::possibleNumeric)))
return(x[components])
})
}
if (any(objs == 3)) {
toreturn$qmc <- lapply(mget(names(objs[objs == 3]), env), function(x) {
components <- c("indexes", "noflevels", "cases", "options")
x <- x$tt
cnds <- x$options$conditions
if (x$options$use.letters) {
cnds <- LETTERS[seq(length(cnds))]
}
if (length(cnds) <= 7) {
x$id <- apply(x$tt[, cnds], 1, function(x) {
ifelse(any(x == 1), paste(which(x == 1), collapse=""), "0")
})
components <- c(components, "id", "tt")
}
x$indexes <- x$indexes - 1
return(x[components])
})
}
}
return(toreturn)
}
calibrateit <- function(foo) {
scrollvh <- lapply(foo$scrollvh, function(x) unlist(x) + 1)
checks <- rep(TRUE, 9)
checks[1] <- !is.null(ev[[foo$dataset]])
foo$thresholds <- unlist(foo$thresholds)
nms <- unlist(foo$thnames)[foo$thresholds != ""]
foo$thresholds <- foo$thresholds[foo$thresholds != ""]
thrs <- suppressWarnings(as.numeric(foo$thresholds))
if (any(!is.na(thrs))) {
foo$thresholds <- as.numeric(thrs[!is.na(thrs)])
}
if (all(foo$thresholds == "")) {
foo$thresholds <- NA
}
else {
if (!is.null(nms)) {
if (length(nms) == length(foo$thresholds)) {
if (foo$type == "fuzzy") {
names(foo$thresholds) <- nms
}
}
else {
foo$thresholds <- NA
}
}
}
checks[4] <- foo$x != ""
if (checks[1] & checks[4]) {
if (foo$x %in% names(ev[[foo$dataset]])) {
checks[6] <- is.numeric(ev[[foo$dataset]][, foo$x])
}
}
if (possibleNumeric(foo$idm)) {
foo$idm <- as.numeric(foo$idm)
}
if (possibleNumeric(foo$below)) {
foo$below <- as.numeric(foo$below)
}
if (possibleNumeric(foo$above)) {
foo$above <- as.numeric(foo$above)
}
if (all(checks)) {
textoutput <- capture.output(tryCatch(
calibrate(
ev[[foo$dataset]][, foo$x],
type = foo$type,
thresholds = foo$thresholds,
logistic = foo$logistic,
idm = foo$idm,
ecdf = foo$ecdf,
below = foo$below,
above = foo$above), error = function(e) e)
)
response <- list()
response$origin <- "calibrate"
response$error <- FALSE
response$toprint <- ""
if (any(error <- grepl("Error", textoutput))) {
errmessage <- paste0("Error:", unlist(strsplit(textoutput[which(error)], split=":"))[2])
errmessage <- substr(errmessage, 1, nchar(errmessage) - 1)
response$error <- TRUE
response$toprint <- errmessage
}
else {
fuzzyvals <- calibrate(
ev[[foo$dataset]][, foo$x],
type = foo$type,
thresholds = foo$thresholds,
logistic = foo$logistic,
idm = foo$idm,
ecdf = foo$ecdf,
below = foo$below,
above = foo$above)
if (!foo$thsetter) {
ev[[foo$dataset]][, ifelse(foo$newvar != "", foo$newvar, foo$x)] <- fuzzyvals
}
}
if (foo$thsetter) {
if (!response$error) {
return(list(fuzzyvals = fuzzyvals))
}
}
else {
response$infobjs <- infobjs(ev, foo$dataset, scrollvh)
response$toprint <- paste(response$toprint, collapse = "<br>")
response$dataset <- foo$dataset
if (foo$newvar == "") {
response$poinths <- list(dataset = foo$dataset,
condition = foo$x,
vals = unname(ev[[foo$dataset]][, foo$x]),
fuzzyvals = fuzzyvals)
if (foo$findth) {
response$poinths$thvals <- as.list(findTh(ev[[foo$dataset]][, foo$x], n = foo$nth))
response$poinths$message <- "OK"
}
}
return(list(response = response))
}
}
}
tryCatchWEM <- function(expr) {
toreturn <- list()
output <- withVisible(withCallingHandlers(
tryCatch(expr, error = function(e) {
toreturn$error <<- e$message
NULL
}), warning = function(w) {
toreturn$warning <<- c(toreturn$warning, w$message)
invokeRestart("muffleWarning")
}, message = function(m) {
toreturn$message <<- paste(toreturn$message, m$message, sep = "")
invokeRestart("muffleMessage")
}
))
if (output$visible) {
if (!is.null(output$value)) {
toreturn$output <- capture.output(output$value)
}
}
if (length(toreturn) > 0) {
return(toreturn)
}
}
continue <- lapply(c("ls(", "'ls"), function(x) {
x <- unlist(strsplit(unlist(strsplit(tryCatch(eval(parse(text = x)), error = identity)$message, "\n"))[1], ":"))
return(admisc::trimstr(x[length(x)]))
})
evalparse <- function(foo) {
forbidden <- "dev.new\\(|plot.new\\(|plot.window\\(|X11\\(|quartz\\(|dev.set\\(|windows\\("
evaluateit <- list()
tocheck <- rep(c("\n", "@$%$@"), each = 3)
names(tocheck) <- c("output", "view", "message", "warning", "error", "library")
if (any(ggplot <- grep("ggplot\\(|qplot\\(|quickplot\\(", foo))) {
foo[ggplot] <- paste("SOME__BIG__NAME <-", foo[ggplot])
foo <- c(foo, "print(SOME__BIG__NAME)")
}
ggplot <- any(ggplot)
nextpos <- 1
temptxt <- foo[1]
parsem <- NULL
for (i in seq_along(foo)) {
endcom <- TRUE
temp <- tryCatch(parse(text = temptxt), error = identity)
if (inherits(temp, "error")) {
if (any(unlist(lapply(continue, grepl, temp)))) {
if (i < length(foo)) {
temptxt <- paste(foo[seq(nextpos, i + 1)], collapse = "\n")
endcom <- FALSE
}
}
}
if (endcom) {
parsem <- c(parsem, temptxt)
nextpos <- i + 1
temptxt <- foo[nextpos]
}
}
parsem_length <- length(parsem)
if (identical(parsem[parsem_length], "print(SOME__BIG__NAME)")) {
parsem_length <- parsem_length - 1
}
evaluateit <- vector(mode = "list", length = parsem_length)
recall <- vector(mode = "list", length = parsem_length)
noerror <- TRUE
i <- 1
while (i <= length(parsem) & noerror) {
evaluateit[[i]] <- list()
if (grepl(forbidden, gsub(" ", "", parsem[i]))) {
evaluateit[[i]][["error"]] <- " Opening multiple graphics devices is not supported."
}
else {
sf <- srcfile("parsem[i]")
temp <- tryCatch(parse(text = parsem[i], srcfile = sf), error = identity, warning = identity)
if (inherits(temp, "error")) {
gpd <- getParseData(sf)
parsesplit <- parsem[i]
if (any(gpd$token == "';'")) {
pos <- c(0, gpd$col1[gpd$token == "';'"], nchar(parsem[i]) + 1)
parsesplit <- c()
for (p in seq(length(pos) - 1)) {
parsesplit <- c(parsesplit, substr(parsem[i], pos[p] + 1, pos[p + 1] - 1))
}
}
errors <- logical(length(parsesplit))
for (j in seq(length(parsesplit))) {
errors[j] <- inherits(tryCatch(parse(text = parsesplit[j]), error = identity), "error")
}
parsesplit <- parsesplit[seq(which(errors)[1])]
}
else {
ptfep <- function(x) {
x <- unlist(strsplit(x, split = ""))
what <- unlist(strsplit("eval(parse(text=", split = ""))
counter <- length(what)
while (counter > 0) {
if (x[1] == " ") {
x <- x[-1]
}
else {
if (x[1] == what[1]) {
x <- x[-1]
if (what[1] == "(") {
x <- x[-length(x)]
}
what <- what[-1]
counter <- counter - 1
}
}
}
x <- admisc::trimstr(paste(x, collapse = ""))
x <- gsub("^\\\"", "", x)
x <- gsub("\\\"$", "", x)
x <- gsub("\\\\\"", "\"", x)
x <- admisc::trimstr(x)
if (grepl("^eval\\(parse\\(text=", gsub(" ", "", x))) {
return(Recall(x))
}
else {
x <- gsub("\\\\\"", "\"", x)
return(x)
}
}
parsesplit <- as.character(parse(text = parsem[i]))
}
if (length(parsesplit) > 1) {
recalsplit <- vector(mode = "list", length = length(parsesplit))
for (j in seq(length(recalsplit))) {
recalsplit[[j]] <- Recall(parsesplit[j])
temp <- list()
for (tc in names(tocheck)) {
tempcheck <- unlist(lapply(recalsplit[[j]], function(x) return(x[[tc]])))
if (!is.null(tempcheck)) {
temp[[tc]] <- paste(tempcheck, collapse = tocheck[[tc]])
}
}
recalsplit[[j]] <- temp
}
temp <- list()
for (tc in names(tocheck)) {
tempcheck <- unlist(lapply(recalsplit, function(x) return(x[[tc]])))
if (!is.null(tempcheck)) {
temp[[tc]] <- paste(tempcheck, collapse = tocheck[[tc]])
}
}
errors <- unlist(lapply(recalsplit, function(x) return("error" %in% names(x))))
if (any(errors)) {
temp$partial <- paste(paste(parsesplit[seq(which(errors)[1] - 1)], collapse = ";"), ";", sep="")
}
recall[[i]] <- temp
}
else {
evaluateit[[i]][["source"]] <- grepl("^source\\(", gsub(" ", "", parsem[i]))
if (evaluateit[[i]][["source"]]) {
sourcefile <- gsub("\\\"", "", insideBrackets(parsem[i], type = "("))
if (file.exists(sourcefile)) {
sourcefile <- readLines(sourcefile, warn = FALSE)
temp <- tryCatch(parse(text = sourcefile), error = identity, warning = identity)
if (inherits(temp, "error")) {
errmsg <- temp$message
if (grepl("<text>", errmsg)) {
errmsg <- unlist(strsplit(errmsg, split = "\n"))
errmsg[1] <- paste("in ", parsem[i], ": ", unlist(strsplit(errmsg[1], split = ": "))[2], sep = "")
if (!grepl("unexpected symbol", errmsg[1])) {
errmsg[length(errmsg)] <- substring(errmsg[length(errmsg)], 2)
}
errmsg <- paste(errmsg, collapse = "\n")
}
recall[[i]] <- list(error = errmsg)
noerror <- FALSE
}
else {
recall[[i]] <- Recall(sourcefile)
temp <- list()
for (tc in names(tocheck)) {
tempcheck <- unlist(lapply(recall[[i]], function(x) return(x[[tc]])))
if (!is.null(tempcheck)) {
temp[[tc]] <- paste(tempcheck, collapse = tocheck[[tc]])
}
}
recall[[i]] <- temp
if (any(names(temp) == "error")) {
noerror <- FALSE
}
}
}
else {
errmsg <- paste(c("Error in file(filename, \"r\", encoding = encoding) : ",
" cannot open the connection",
"In addition: Warning message:",
"In file(filename, \"r\", encoding = encoding) :",
paste(" cannot open file '", filename, "': No such file or directory", sep = "")),
collapse = "\n")
}
}
else {
comnd <- parsem[i]
if (grepl("^print\\(", gsub(" ", "", comnd)) & !ggplot) {
comnd <- insideBrackets(comnd, type = "(")
}
object <- ""
objerror <- FALSE
toview <- FALSE
lib <- FALSE
if (grepl("^View\\(", gsub(" ", "", comnd))) {
object <- gsub("\\\"", "", admisc::insideBrackets(comnd, type = "("))
if (object != "") {
if (exists(object, envir = ev)) {
if (is.data.frame(ev[[object]])) {
evaluateit[[i]][["view"]] <- object
toview <- TRUE
}
else {
objerror <- TRUE
evaluateit[[i]][["error"]] <- paste("The object to View (", object, ") is not a dataframe.", sep="")
}
}
}
}
if (!objerror & !toview) {
if (length(temp <- tryCatchWEM(eval(parse(text = comnd), envir = ev))) > 0) {
if (any(names(temp) == "warning")) {
temp$warning <- paste(paste("In", parsem[i], ":"), temp$warning, sep = "\n ")
}
if (any(names(temp) == "error")) {
temp$error <- paste("Error in", comnd, ":\n ", temp$error)
}
evaluateit[[i]] <- temp
}
}
if (grepl("^library\\(", gsub(" ", "", comnd))) {
object <- gsub("\\\"", "", admisc::insideBrackets(comnd, type = "("))
if (object != "") {
evaluateit[[i]][["library"]] <- object
}
}
}
}
if (!is.null(evaluateit[[i]][["error"]])) {
if (grepl("plot.new has not been called yet", evaluateit[[i]][["error"]])) {
if (!identical(grafic, emptyplot)) {
pdf(templotfile)
dev.control("enable")
replayPlot(grafic)
evaluateit[[i]][["output"]] <- capture.output(suppressWarnings(eval(parse(text = parsem[i]), envir = ev)))
if (length(evaluateit[[i]][["output"]]) == 0) {
evaluateit[[i]][["output"]] <- NULL
}
if (length(dev.list()) > 0) {
testplot <<- recordPlot()
sapply(dev.list(), dev.off)
}
evaluateit[[i]][["error"]] <- NULL
svg(filename = svgfile, width = plotsize[1], height = plotsize[2])
replayPlot(grafic)
dev.off()
}
}
else {
noerror <- FALSE
}
}
}
if (length(recall[[i]]) > 0) {
for (tc in names(tocheck)) {
if (tc %in% names(recall[[i]])) {
if (any(tc %in% names(evaluateit[[i]]))) {
evaluateit[[i]][[tc]] <- paste(c(evaluateit[[i]][[tc]], recall[[i]][[tc]]), collapse = tocheck[[tc]])
}
else {
evaluateit[[i]][[tc]] <- paste(recall[[i]][[tc]], collapse = tocheck[[tc]])
}
}
}
if ("partial" %in% names(recall[[i]])) {
evaluateit[[i]][["partial"]] <- recall[[i]][["partial"]]
}
if ("library" %in% names(recall[[i]])) {
evaluateit[[i]][["library"]] <- recall[[i]][["library"]]
}
}
if (!ggplot) {
evaluateit[[i]][["command"]] <- gsub("SOME__BIG__NAME <- ", "", parsem[i])
evaluateit[[i]][["continue"]] <- FALSE
errmsg <- evaluateit[[i]][["error"]]
if (!is.null(errmsg)) {
if (any(unlist(lapply(continue, grepl, errmsg)))) {
sf <- srcfile("parsem[i]")
temp <- tryCatch(parse(text = parsem[i], srcfile = sf), error = identity, warning = identity)
if (inherits(temp, "error")) {
evaluateit[[i]][["continue"]] <- TRUE
}
}
if (grepl("<text>", errmsg)) {
errmsg <- unlist(strsplit(errmsg, split = "\n"))
errmsg[1] <- paste("Error:", unlist(strsplit(errmsg[1], split = ": "))[2], "in:")
if (!grepl("unexpected symbol", errmsg[1])) {
errmsg[length(errmsg)] <- substring(errmsg[length(errmsg)], 2)
}
errmsg <- paste(errmsg, collapse = "\n")
}
evaluateit[[i]][["error"]] <- errmsg
}
if (length(evaluateit[[i]][["output"]]) == 0) {
evaluateit[[i]][["output"]] <- NULL
}
else {
evaluateit[[i]][["output"]] <- paste(evaluateit[[i]][["output"]], collapse = "\n")
}
if ("view" %in% names(evaluateit[[i]])) {
views <- unlist(strsplit(evaluateit[[i]][["view"]], split = "\n"))
evaluateit[[i]][["view"]] <- views[length(views)]
}
if ("source" %in% names(evaluateit[[i]])) {
if (evaluateit[[i]][["source"]]) {
evaluateit[[i]][["continue"]] <- FALSE
}
}
}
i <- i + 1
}
return(evaluateit)
}
getDatasets <- function() {
attached <- data()$results[, -2]
packages <- unique(attached[, "Package"])
attached <- lapply(packages, function(x) {
x <- attached[attached[, "Package"] == x, 2:3, drop = FALSE]
x <- x[x[, 2] != "Internal Functions", , drop = FALSE]
titles <- as.list(x[, 2])
names(titles) <- x[, 1]
return(titles)
})
names(attached) <- packages
return(attached)
}
getXasp <- function(x, type = "default") {
clr <- range(x, na.rm = TRUE)
pdf(templotfile)
if (type == "default") {
plot(seq(clr[1], clr[2], length.out = 100), seq(100), xlim = clr, type = "n", axes = FALSE)
axis(1)
}
else if (type == "pretty") {
plot(x, type = "n", axes = FALSE)
axis(1, at = pretty(x))
}
else if (type == "margins") {
plot(x, type = "n", axes = FALSE)
axis(1, at = clr)
}
xasp <- par("xaxp")
dev.off()
file.remove(templotfile)
return(xasp)
}
getXYplot <- function(foo) {
X <- ev[[foo$dataset]][, foo$x]
Y <- ev[[foo$dataset]][, foo$y]
notX <- 1 - X
notY <- 1 - Y
rpofsuf <- list(pof( X, Y, rel = "suf"),
pof(notX, Y, rel = "suf"),
pof( X, notY, rel = "suf"),
pof(notX, notY, rel = "suf"))
rpofsuf <- lapply(rpofsuf, function(x) {
formatC(c(x$incl.cov$inclS, x$incl.cov$covS, x$incl.cov$PRI), format="f", digits = 3)
})
rpofnec <- list(pof( X, Y),
pof(notX, Y),
pof( X, notY),
pof(notX, notY))
rpofnec <- lapply(rpofnec, function(x) {
formatC(c(x$incl.cov$inclN, x$incl.cov$covN, x$incl.cov$RoN), format="f", digits = 3)
})
return(list(rownames(ev[[foo$dataset]]), ev[[foo$dataset]][, foo$x], ev[[foo$dataset]][, foo$y], rpofsuf, rpofnec))
}
numhash <- function(x) {
mean(as.integer(charToRaw(paste(capture.output(.Internal(inspect(x))), collapse = ""))))
}
warningstack <- NULL
ev <- new.env(parent = globalenv())
hashes <- list()
templotfile <- file.path(tempdir(), "plot.pdf")
visiblerows <- 17
visiblecols <- 8
pdf(templotfile)
emptyplot <- testplot <- recordPlot()
plotsize <- rep(5.729167, 2)
sapply(dev.list(), dev.off)
file.remove(templotfile)
grafic <- emptyplot
testplot <- emptyplot
svgfile <- file.path(path.package("QCA"), "gui", "www", "css", "images", "plot.svg")
tempdata <- NULL
current_path <- getwd()
oktoset <- TRUE
filepath <- ""
extension <- ""
tcisdata <- TRUE
shinyServer(function(input, output, session) {
session$onSessionEnded(stopApp)
observe({
dirfilist <- input$dirfilist
session$sendCustomMessage(type = "dirfile", listFiles(current_path))
})
observe({
read_table <- input$read_table
filepath <<- ""
oktoset <<- TRUE
if (!is.null(input$dirfile_chosen)) {
dfchosen <- input$dirfile_chosen
oktoset <<- TRUE
if (dfchosen[1] == "file") {
filepath <<- file.path(gsub("[/]$", "", current_path), dfchosen[2])
}
else {
splitpath <- unlist(strsplit(current_path, split=.Platform$file.sep))
if (dfchosen[2] == ".." | dfchosen[2] == "...") {
if (length(splitpath) > 1) {
splitpath <- splitpath[-length(splitpath)]
}
if (identical(splitpath, "")) {
splitpath <- "/"
}
pathtobe <- paste(splitpath, collapse = .Platform$file.sep)
if (length(list.files(pathtobe)) > 0) {
current_path <<- pathtobe
}
else {
oktoset <<- FALSE
}
}
else {
current_dirs <- listFiles(current_path)$dirs
if (is.element(dfchosen[2], current_dirs)) {
pathtobe <- file.path(current_path, dfchosen[2])
if (length(list.files(pathtobe)) > 0) {
current_path <<- pathtobe
}
else {
oktoset <<- FALSE
}
}
else if (dfchosen[2] != "__stdir__") {
if (dfchosen[2] == "root") {
dfchosen[2] <- ""
}
splitpath <- splitpath[seq(which(splitpath == dfchosen[2]))]
pathtobe <- ifelse(length(splitpath) == 1,
ifelse(identical(splitpath, ""), "/", splitpath),
paste(splitpath, collapse = .Platform$file.sep))
if (length(list.files(pathtobe)) > 0) {
current_path <<- pathtobe
}
else {
oktoset <<- FALSE
}
}
}
}
if (oktoset) {
current_path <<- gsub("//", "/", current_path)
if (!grepl("/", current_path)) {
current_path <<- paste(current_path, "/", sep = "")
}
}
if (dfchosen[1] == "dir" & dfchosen[3] != "") {
if (grepl("cannot change working directory", tryCatch(setwd(dfchosen[3]), error = function(e) e))) {
listtosend <- listFiles(current_path)
listtosend$filename <- "error!"
session$sendCustomMessage(type = "dirfile", listtosend)
}
else {
if (dfchosen[3] %in% listFiles(current_path)$dirs) {
pathtobe <- file.path(current_path, dfchosen[3])
if (length(list.files(pathtobe)) > 0) {
current_path <<- pathtobe
}
}
else {
current_path <<- dfchosen[3]
}
if (!grepl("/", current_path)) {
current_path <<- paste(current_path, "/", sep = "")
}
setwd(current_path)
session$sendCustomMessage(type = "dirfile", listFiles(current_path))
}
}
else {
setwd(current_path)
session$sendCustomMessage(type = "dirfile", listFiles(current_path))
}
}
else {
current_path <<- getwd()
}
if (!identical(filepath, "")) {
numevars <- ""
header <- read_table$header
colsep <- read_table$sep
row_names <- read_table$row_names
decimal <- read_table$dec
filename <- unlist(strsplit(basename(filepath), split="\\."))
filename <- filename[-length(filename)]
if (length(filename) > 1) {
filename <- paste(filename, collapse=".")
}
if (!identical(row_names, "")) {
if (possibleNumeric(row_names)) {
row_names <- as.numeric(row_names)
}
tc <- capture.output(tryCatch(read.table(filepath, header = header, ifelse(colsep == "tab", "\t", colsep),
row.names = row_names, as.is = TRUE, dec = decimal, nrows = 2), error = function(e) e, warning = function(w) w))
}
else {
tc <- capture.output(tryCatch(read.table(filepath, header = header, ifelse(colsep == "tab", "\t", colsep),
as.is = TRUE, dec = decimal, nrows = 2), error = function(e) e, warning = function(w) w))
}
if (any(grepl("subscript out of bounds", tc))) {
mesaj <- paste("The data doesn't have ", row_names, " columns.", sep = "")
session$sendCustomMessage(type = "tempdatainfo", list(ncols = 1, nrows = 1, colnames = mesaj, rownames="error!"))
return(invisible())
}
else if (any(grepl("are not allowed", tc))) {
mesaj <- paste("The row.names column has duplicated values.", sep = "")
session$sendCustomMessage(type = "tempdatainfo", list(ncols = 1, nrows = 1, colnames = mesaj, rownames="error!"))
return(invisible())
}
else if (any(grepl("data frame with 0 columns", tc))) {
mesaj <- paste("The data has only 1 column.", sep = "")
tc <- tryCatch(read.table(filepath, header = header, ifelse(colsep == "tab", "\t", colsep),
as.is = TRUE, dec = decimal, nrows = 2), error = function(e) e)
session$sendCustomMessage(type = "tempdatainfo", list(ncols = 2, nrows = 2, colnames=c(colnames(tc), mesaj), rownames=""))
return(invisible())
}
else if (any(grepl("attempt to select less than one element", tc))) {
mesaj <- paste("The column \"", row_names, "\" was not found.", sep = "")
session$sendCustomMessage(type = "tempdatainfo", list(ncols = 1, nrows = 1, colnames = mesaj, rownames = "error!"))
return(invisible())
}
tc <- tryCatch(read.table(filepath, header = header, ifelse(colsep == "tab", "\t", colsep),
as.is = TRUE, dec = decimal, nrows = 2), error = function(e) e, warning = function(w) w)
tcisdata <<- TRUE
if (is.null(dim(tc))) {
if (is.list(tc)) {
if (identical(names(tc), c("message", "call"))) {
tcisdata <<- FALSE
session$sendCustomMessage(type = "tempdatainfo", list(ncols = 1, nrows = 1, colnames = tc$message, rownames = "error!"))
}
}
}
else {
if (grepl("X.PDF", names(tc)[1])) {
tcisdata <<- FALSE
session$sendCustomMessage(type = "tempdatainfo", list(ncols = 1, nrows = 1, colnames = "not a dataframe, this is a PDF file", rownames="error!"))
}
}
if (tcisdata) {
if (row_names != "") {
tc <- tryCatch(read.table(filepath, header = header, ifelse(colsep == "tab", "\t", colsep),
row.names = row_names, as.is = TRUE, dec = decimal), error = function(e) e, warning = function(w) w)
}
else {
tc <- tryCatch(read.table(filepath, header = header, ifelse(colsep == "tab", "\t", colsep),
as.is = TRUE, dec = decimal), error = function(e) e, warning = function(w) w)
}
if (identical(names(tc), c("message", "call"))) {
session$sendCustomMessage(type = "tempdatainfo", list(ncols = 1, nrows = 1, colnames = tc$message, rownames = "error!"))
}
else {
tempdata <<- tc
cnames <- colnames(tempdata)
if (length(cnames) == 1) {
cnames = list(cnames)
}
rnames <- rownames(tempdata)
if (length(rnames) == 1) {
rnames = list(rnames)
}
session$sendCustomMessage(type = "tempdatainfo", list(ncols = ncol(tempdata),
nrows = nrow(tempdata),
colnames = cnames,
rownames = rnames))
}
}
}
})
observe({
foo <- input$import
if (!is.null(foo) & tcisdata) {
result <- list(infobjs = NULL, console = NULL)
if (foo$nameit) {
ev[[foo$objname]] <- tempdata
}
else {
result$console <- c(capture.output(tempdata), "")
}
result$infobjs <- infobjs(ev, ls(ev))
session$sendCustomMessage(type = "fullinfo", result)
}
})
observe({
foo <- input$scrollobj
if (!is.null(foo)) {
scrollvh <- lapply(foo$scrollvh, function(x) unlist(x) + 1)
visiblerows <<- foo$visiblerows + 1
visiblecols <<- foo$visiblecols + 1
if (!foo$alldata) {
scrollvh <- scrollvh[foo$dataset]
}
tosend <- vector(mode = "list", length = length(scrollvh))
names(tosend) <- names(scrollvh)
for (n in names(scrollvh)) {
nrowd <- nrow(ev[[n]])
ncold <- ncol(ev[[n]])
dscrollvh <- scrollvh[[n]]
srow <- min(dscrollvh[1], nrowd - min(nrowd, visiblerows) + 1)
scol <- min(dscrollvh[2], ncold - min(ncold, visiblecols) + 1)
erow <- min(srow + visiblerows - 1, nrowd)
ecol <- min(scol + visiblecols - 1, ncold)
tosend[[n]] <- list(
theData = unname(as.list(ev[[n]][seq(srow, erow), seq(scol, ecol), drop = FALSE])),
dataCoords = paste(srow, scol, erow, ecol, ncold, sep="_"),
scrollvh = c(srow, scol) - 1
)
}
session$sendCustomMessage(type = "scrollData", tosend)
}
})
observe({
foo <- input$thinfo
if (!is.null(foo)) {
response <- list()
response$message <- "OK"
if (foo$x != "") {
foo$nth <- as.numeric(foo$nth)
if (possibleNumeric((ev[[foo$dataset]][, foo$x]))) {
xasp <- getXasp(ev[[foo$dataset]][, foo$x])
response$vals <- unname(ev[[foo$dataset]][, foo$x])
response$thvals <- vector(length = 0)
response$fuzzyvals <- list()
response$prettyx <- seq(xasp[1], xasp[2], length.out = xasp[3] + 1)
if (foo$findth) {
response$thvals <- as.list(findTh(ev[[foo$dataset]][, foo$x], n = foo$nth))
}
}
else {
response$message <- "notnumeric"
}
session$sendCustomMessage(type = "dataPoints", response)
}
}
})
observe({
foo <- input$calibrate
if (!is.null(foo)) {
checkit <- calibrateit(foo)
if ("fuzzyvals" %in% names(checkit)) {
session$sendCustomMessage(type = "fuzzyvals", checkit$fuzzyvals)
}
else {
session$sendCustomMessage(type = "calibrate", checkit$response)
}
}
})
observe({
foo <- input$xyplot
if (!is.null(foo)) {
if (all(is.element(c(foo$x, foo$y), names(ev[[foo$dataset]])))) {
session$sendCustomMessage(type = "xyplot", getXYplot(foo))
}
}
})
observe({
foo <- input$Rcommand
if (!is.null(foo)) {
if (length(foo$plotsize) > 0) {
plotsize <<- unlist(foo$plotsize)
}
calib_before <- calib_after <- ""
xyplot_before <- xyplot_after <- ""
recalibrate <- FALSE
if (length(foo$calibrate) > 0) {
calib_before <- numhash(ev[[foo$calibrate$dataset]][, foo$calibrate$x, drop = FALSE])
if (foo$calibrate$thsetter) {
recalibrate <- TRUE
tocalibrate <- foo$calibrate
}
}
if (length(foo$xyplot) > 0) {
xyplot_before <- numhash(ev[[foo$xyplot$dataset]][, c(foo$xyplot$x, foo$xyplot$y), drop = FALSE])
}
scrollvh <- lapply(foo$scrollvh, function(x) unlist(x) + 1)
thinfo <- foo$thinfo
hashes_before <- lapply(ev, function(x) {
numhash(x)
})
if (length(dev.list()) > 0) {
sapply(dev.list(), dev.off)
}
command <- unlist(strsplit(gsub(" ", " ", foo$command), split = "\n"))
tosend <- list(evaluate = NULL, plot = FALSE, added = NULL, modified = NULL, deleted = NULL)
rm(list = ls(envir = globalenv()), envir = globalenv())
testplot <<- emptyplot
pdf(templotfile)
dev.control("enable")
if (identical(command, "warnings()")) {
if (is.null(warningstack)) {
warnmsg <- "NULL"
}
else {
if (length(warningstack) == 1) {
warnmsg <- paste("Warning message: ", warningstack, sep = "\n")
}
else {
warnmsg <- paste(c("Warning messages: ", paste(seq(length(warningstack)), warningstack, sep = ": ")), collapse = "\n")
}
}
tosend$evaluate <- list(list(command = command, output = warnmsg, continue = FALSE))
}
else {
tosend$evaluate <- evalparse(command)
}
lib <- unlist(lapply(tosend$evaluate, function(x) {
if (any(names(x) == "library")) {
return(unlist(strsplit(x$library, split = "\\@\\$\\%\\$\\@")))
}
}))
libcar <- "car" %in% lib
if (!identical(lib, NULL)) {
session$sendCustomMessage(type = "packages", getDatasets())
}
tosend$evaluate <- lapply(tosend$evaluate, function(x) {
if (any(names(x) == "warning")) {
x$warning <- unlist(strsplit(x$warning, split = "\\@\\$\\%\\$\\@"))
if (length(x$warning) == 1) {
warningstack <<- unlist(x$warning)
x$warning <- list(paste("Warning message:", x$warning, sep = "\n"))
}
else {
if (length(x$warning) > 50) {
warningstack <<- unlist(x$warning[1:50])
x$warning <- list("There were 50 or more warnings (use warnings() to see the first 50)")
}
else {
warningstack <<- unlist(x$warning)
x$warning <- list(paste(c("Warning messages:", paste(seq(length(warningstack)), warningstack, sep = ": ")), collapse = "\n"))
}
}
}
return(x)
})
globjs <- ls(envir = globalenv())
added <- NULL
if (length(globjs) >= 0) {
for (i in globjs) {
if (any(names(ev) == i) & is.data.frame(get(i, globalenv()))) {
added <- c(added, i)
}
assign(i, get(i, globalenv()), ev)
}
rm(list = ls(envir = globalenv()), envir = globalenv())
}
if (length(dev.list()) > 0) {
testplot <- recordPlot()
sapply(dev.list(), dev.off)
}
if (!identical(testplot, emptyplot) & !libcar) {
grafic <<- testplot
tosend$plot <- TRUE
svg(filename = svgfile, width = plotsize[1], height = plotsize[2])
replayPlot(grafic)
dev.off()
}
sapply(dev.list(), dev.off)
if (exists("SOME__BIG__NAME", envir = ev)) {
rm("SOME__BIG__NAME", envir = ev)
}
if (file.exists("Rplots.pdf")) {
file.remove("Rplots.pdf")
}
hashes_after <- lapply(ev, function(x) {
numhash(x)
})
if (length(foo$calibrate) > 0) {
calib_after <- numhash(ev[[foo$calibrate$dataset]][, foo$calibrate$x, drop = FALSE])
}
if (length(foo$xyplot) > 0) {
xyplot_after <- numhash(ev[[foo$xyplot$dataset]][, c(foo$xyplot$x, foo$xyplot$y), drop = FALSE])
}
added <- c(added, setdiff(names(hashes_after), names(hashes_before)))
deleted <- setdiff(names(hashes_before), names(hashes_after))
common <- intersect(names(hashes_before), names(hashes_after))
modified <- names(hashes_before)[!is.element(hashes_before[common], hashes_after[common])]
if (length(modified) > 0) {
tosend$modified <- infobjs(ev, modified, scrollvh)
}
if (length(added) > 0) {
tosend$added <- infobjs(ev, added)
}
if (length(deleted) > 0) {
tosend$deleted <- as.list(deleted)
}
if (!identical(calib_before, calib_after)) {
xasp <- getXasp(ev[[foo$calibrate$dataset]][, foo$calibrate$x])
tosend$poinths <- list(dataset = foo$calibrate$dataset,
x = foo$calibrate$x,
rownames = rownames(ev[[foo$calibrate$dataset]]),
vals = unname(as.vector(ev[[foo$calibrate$dataset]][, foo$calibrate$x])),
fuzzyvals = list(),
prettyx = seq(xasp[1], xasp[2], length.out = xasp[3] + 1))
if (recalibrate) {
checkit <- calibrateit(tocalibrate)
if (is.element("fuzzyvals", names(checkit))) {
tosend$poinths$fuzzyvals <- checkit$fuzzyvals
}
}
if (foo$calibrate$findth) {
tosend$poinths$thvals <- findTh(ev[[foo$calibrate$dataset]][, foo$calibrate$x], n = foo$calibrate$nth)
if (length(tosend$poinths$thvals) == 1) {
tosend$poinths$thvals <- as.list(tosend$poinths$thvals)
}
tosend$poinths$message <- "OK"
}
}
if (!identical(xyplot_before, xyplot_after)) {
tosend$xyplot <- getXYplot(foo$xyplot)
}
session$sendCustomMessage(type = "Rcommand", tosend)
}
})
observe({
foo <- input$changes
if (!is.null(foo)) {
session$sendCustomMessage(type = "getChanges", readLines(system.file("ChangeLog", package="QCA")))
}
})
observe({
foo <- input$help
if (!is.null(foo)) {
browseURL(file.path(path.package("QCA"), "staticdocs", "index.html"))
}
})
observe({
foo <- input$pingobj
if (!is.null(foo)) {
session$sendCustomMessage(type = "ping", paste("bar", foo))
}
})
observe({
foo <- input$closeplot
if (!is.null(foo)) {
if (file.exists(svgfile)) {
file.remove(svgfile)
}
grafic <<- emptyplot
svg(filename = svgfile)
replayPlot(grafic)
sapply(dev.list(), dev.off)
}
})
observe({
foo <- input$saveRplot
if (!is.null(foo)) {
filename <- paste(foo$filename, foo$type, sep=".")
if (foo$type == "png") {
png(filename, width = plotsize[1]*96, height = plotsize[2]*96)
}
else if (foo$type == "bmp") {
bmp(filename, width = plotsize[1]*96, height = plotsize[2]*96)
}
else if (foo$type == "jpeg") {
jpeg(filename, width = plotsize[1]*96, height = plotsize[2]*96)
}
else if (foo$type == "tiff") {
tiff(filename, width = plotsize[1]*96, height = plotsize[2]*96)
}
else if (foo$type == "svg") {
svg(filename, width = plotsize[1], height = plotsize[2])
}
else if (foo$type == "pdf") {
pdf(filename, width = plotsize[1], height = plotsize[2])
}
replayPlot(grafic)
dev.off()
}
})
observe({
foo <- input$plotsize
if (!is.null(foo)) {
if (!identical(grafic, emptyplot)) {
plotsize <<- foo
svg(filename = svgfile, width = plotsize[1], height = plotsize[2])
replayPlot(grafic)
dev.off()
session$sendCustomMessage(type = "resizePlot", TRUE)
}
else {
session$sendCustomMessage(type = "resizePlot", FALSE)
}
}
})
observe({
foo <- input$quit
if (!is.null(foo)) {
if (file.exists(svgfile)) {
file.remove(svgfile)
}
session$sendCustomMessage(type = "okquit", list(1))
}
})
session$sendCustomMessage(type = "fullinfo", list(infobjs = infobjs(ev, ls(ev)), console = NULL))
session$sendCustomMessage(type = "packages", getDatasets())
})
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.