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.
`as.panel` <- function(x, row.names) {
if (!missing(row.names)) {
if (is.character(row.names)) {
if (length(row.names) == 1L) {
rowvar <- (1L:ncol(x))[match(colnames(x), row.names, 0L) == 1L]
row.names <- x[[rowvar]]
x <- x[-rowvar]
}
}
else if (is.numeric(row.names) && length(row.names) == 1L) {
rowvar <- row.names
row.names <- x[[rowvar]]
x <- x[-rowvar]
}
else {
cat("\n")
stop(simpleError("invalid 'row.names' specification.\n\n"))
}
if (is.object(row.names) || !(is.integer(row.names))) {
row.names <- as.character(row.names)
}
if (anyNA(row.names)) {
cat("\n")
stop(simpleError("missing values in 'row.names' are not allowed.\n\n"))
}
attr(x, "row.names") <- row.names
}
if (!is.data.frame(x)) {
x <- as.data.frame(x, stringsAsFactors = FALSE)
}
structure(x, class = c("panel", "data.frame"))
}
`[.panel` <- function(x, i, j, ...) {
funargs <- unlist(lapply(match.call(), deparse)[-1])
drop <- TRUE
if (any(names(funargs) == "drop")) {
drop <- as.logical(funargs["drop"])
}
rownms <- row.names(x)
class(x) <- "data.frame"
classes <- lapply(x, class)
clevels <- lapply(x, levels)
cordered <- lapply(x, is.ordered)
x <- eval(parse(text = sprintf("x[%s, %s, drop = %s]", funargs["i"], funargs["j"], drop)))
if (!is.null(dim(x))) {
x <- as.matrix(x)
rownms <- eval(parse(text = sprintf("rownms[%s]", funargs["i"])))
row.names(x) <- rownms
x <- rebuild(as.data.frame(x, stringsAsFactors = FALSE),
classes[colnames(x)], clevels[colnames(x)], cordered[colnames(x)])
class(x) <- c("QCA_panel", "data.frame")
}
return(x)
}
`row.names<-.panel` <- function(x, value) {
classes <- lapply(x, class)
clevels <- lapply(x, levels)
cordered <- lapply(x, is.ordered)
x <- as.matrix(x)
setRownames(x, value)
x <- rebuild(as.data.frame(x, stringsAsFactors = FALSE), classes, clevels, cordered)
class(x) <- c("QCA_panel", "data.frame")
return(x)
}
`rebuild` <- function(x, classes, clevels, cordered) {
for (i in seq(ncol(x))) {
x[[i]] <- if (is.element("factor", classes[[i]])){
factor(x[[i]], levels = clevels[[i]], ordered = cordered[[i]])
}
else if (is.element("Date", classes[[i]])) {
as.Date(x[[i]])
}
else if (is.element("POSIXct", classes[[i]])) {
as.POSIXct(x[[i]])
}
else {
methods::as(x[[i]], classes[[i]])
}
}
return(x)
}
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.