Last updated on 2020-03-07 11:48:33 CET.
| Flavor | Version | Tinstall | Tcheck | Ttotal | Status | Flags |
|---|---|---|---|---|---|---|
| r-devel-linux-x86_64-debian-clang | 1.7.7 | 10.63 | 83.29 | 93.92 | ERROR | |
| r-devel-linux-x86_64-debian-gcc | 1.7.7 | 9.69 | 63.91 | 73.60 | ERROR | |
| r-devel-linux-x86_64-fedora-clang | 1.7.7 | 113.91 | ERROR | |||
| r-devel-linux-x86_64-fedora-gcc | 1.7.7 | 110.39 | ERROR | |||
| r-devel-windows-ix86+x86_64 | 1.7.7 | 30.00 | 100.00 | 130.00 | OK | |
| r-devel-windows-ix86+x86_64-gcc8 | 1.7.7 | 23.00 | 95.00 | 118.00 | OK | |
| r-patched-linux-x86_64 | 1.7.7 | 9.35 | 70.64 | 79.99 | OK | |
| r-patched-solaris-x86 | 1.7.7 | 159.30 | OK | |||
| r-release-linux-x86_64 | 1.7.7 | 10.31 | 71.19 | 81.50 | OK | |
| r-release-windows-ix86+x86_64 | 1.7.7 | 15.00 | 92.00 | 107.00 | OK | |
| r-release-osx-x86_64 | 1.7.7 | OK | ||||
| r-oldrel-windows-ix86+x86_64 | 1.7.7 | 9.00 | 88.00 | 97.00 | OK | |
| r-oldrel-osx-x86_64 | 1.7.7 | OK |
Version: 1.7.7
Check: examples
Result: ERROR
Running examples in 'xergm.common-Ex.R' failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: adjust
> ### Title: Adjust the dimensions of a matrix to the dimensions of another
> ### matrix
> ### Aliases: adjust
>
> ### ** Examples
>
> # create sociomatrix a with 13 vertices a to m
> vertices <- letters[1:13]
> a <- matrix(rbinom(length(vertices)^2, 1, 0.1), nrow = length(vertices))
> rownames(a) <- colnames(a) <- vertices
>
> # create sociomatrix b with the same vertices except f and k, but additional n
> vertices <- c(vertices[-c(6, 11)], "n")
> b <- matrix(rbinom(length(vertices)^2, 1, 0.1), nrow = length(vertices))
> rownames(b) <- colnames(b) <- vertices
>
> # check dimensions
> dim(a) # 13 x 13
[1] 13 13
> dim(b) # 12 x 12
[1] 12 12
>
> # adjust a to b: add n and fill up with NAs; remove f and k
> adjust(a, b, add = TRUE, remove = TRUE)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
xergm.common
--- call from context ---
adjust(a, b, add = TRUE, remove = TRUE)
--- call from argument ---
if (class(source) == "matrix") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "matrix"
} else if (class(source) == "network") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "network"
} else if (class(source) == "list") {
sources <- source
sources.initialtype <- "list"
} else if (is.vector(source)) {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "vector"
} else {
stop(paste("Source data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
--- R stacktrace ---
where 1: adjust(a, b, add = TRUE, remove = TRUE)
--- value of length: 2 type: logical ---
[1] TRUE FALSE
--- function from context ---
function (source, target, remove = TRUE, add = TRUE, value = NA,
returnlabels = FALSE)
{
if (is.null(source)) {
stop("The 'source' argument was not recognized.")
}
else if (class(source) == "matrix") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "matrix"
}
else if (class(source) == "network") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "network"
}
else if (class(source) == "list") {
sources <- source
sources.initialtype <- "list"
}
else if (is.vector(source)) {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "vector"
}
else {
stop(paste("Source data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
if (is.null(target)) {
stop("The 'target' argument was not recognized.")
}
else if (class(target) == "matrix") {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "matrix"
}
else if (class(target) == "network") {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "network"
}
else if (class(target) == "list") {
targets <- target
targets.initialtype <- "list"
}
else if (is.vector(target)) {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "vector"
}
else {
stop(paste("Target data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
if (length(sources) == length(targets)) {
}
else if (length(sources) == 1) {
for (i in 2:length(targets)) {
sources[[i]] <- sources[[1]]
}
}
else if (length(targets) == 1) {
for (i in 2:length(sources)) {
targets[[i]] <- targets[[1]]
}
}
else {
stop("Different numbers of sources and targets were provided.")
}
sources.attribnames <- list()
sources.attributes <- list()
sources.types <- list()
sources.onemode <- list()
sources.directed <- list()
sources.matrixnames <- list()
sources.matrices <- list()
targets.attribnames <- list()
targets.attributes <- list()
targets.types <- list()
targets.onemode <- list()
targets.directed <- list()
for (i in 1:length(sources)) {
sources.types[[i]] <- class(sources[[i]])
if (class(sources[[i]]) == "network") {
sources.attribnames[[i]] <- list.vertex.attributes(sources[[i]])
attributes <- list()
if (!is.null(sources.attribnames[[i]]) && length(sources.attribnames[[i]]) >
0) {
for (j in 1:length(sources.attribnames[[i]])) {
attributes[[j]] <- get.vertex.attribute(sources[[i]],
sources.attribnames[[i]][j])
}
}
sources.attributes[[i]] <- attributes
sources.onemode[[i]] <- !is.bipartite(sources[[i]])
sources.directed[[i]] <- is.directed(sources[[i]])
temp <- list.network.attributes(sources[[i]])
temp <- temp[!temp %in% c("bipartite", "directed",
"hyper", "loops", "mnext", "multiple", "n")]
if (length(temp) > 0) {
for (j in length(temp):1) {
if (!class(get.network.attribute(sources[[i]],
temp[j])) %in% c("network", "matrix", "Matrix")) {
temp <- temp[-j]
}
}
}
sources.matrixnames[[i]] <- temp
matrices <- list()
if (!is.null(sources.matrixnames[[i]]) && length(sources.matrixnames[[i]]) >
0) {
for (j in 1:length(sources.matrixnames[[i]])) {
matrices[[j]] <- get.network.attribute(sources[[i]],
sources.matrixnames[[i]][j])
}
}
sources.matrices[[i]] <- matrices
rm(temp)
sources[[i]] <- as.matrix(sources[[i]])
}
else if (class(sources[[i]]) == "matrix") {
sources.onemode[[i]] <- is.mat.onemode(sources[[i]])
sources.directed[[i]] <- is.mat.directed(sources[[i]])
}
else {
sources[[i]] <- as.matrix(sources[[i]], ncol = 1)
}
targets.types[[i]] <- class(targets[[i]])
if (class(targets[[i]]) == "network") {
targets.attribnames[[i]] <- list.vertex.attributes(targets[[i]])
attributes <- list()
if (!is.null(targets.attribnames[[i]]) && length(targets.attribnames[[i]]) >
0) {
for (j in 1:length(targets.attribnames[[i]])) {
attributes[[j]] <- get.vertex.attribute(targets[[i]],
targets.attribnames[[i]][j])
}
}
targets.attributes[[i]] <- attributes
targets.onemode[[i]] <- !is.bipartite(targets[[i]])
targets.directed[[i]] <- is.directed(targets[[i]])
targets[[i]] <- as.matrix(targets[[i]])
}
else if (class(targets[[i]]) == "matrix") {
targets.onemode[[i]] <- is.mat.onemode(targets[[i]])
targets.directed[[i]] <- is.mat.directed(targets[[i]])
}
else {
targets[[i]] <- as.matrix(targets[[i]], ncol = 1)
}
}
for (i in 1:length(sources)) {
if (is.null(rownames(sources[[i]])) && !is.null(colnames(sources[[i]])) &&
nrow(sources[[i]]) == ncol(sources[[i]])) {
rownames(sources[[i]]) <- colnames(sources[[i]])
}
if (is.null(colnames(sources[[i]])) && !is.null(rownames(sources[[i]])) &&
nrow(sources[[i]]) == ncol(sources[[i]])) {
colnames(sources[[i]]) <- rownames(sources[[i]])
}
if (is.null(rownames(targets[[i]])) && !is.null(colnames(targets[[i]])) &&
nrow(targets[[i]]) == ncol(targets[[i]])) {
rownames(targets[[i]]) <- colnames(targets[[i]])
}
if (is.null(colnames(targets[[i]])) && !is.null(rownames(targets[[i]])) &&
nrow(targets[[i]]) == ncol(targets[[i]])) {
colnames(targets[[i]]) <- rownames(targets[[i]])
}
}
for (i in 1:length(sources)) {
if (class(sources[[i]]) %in% c("matrix", "data.frame")) {
if (!is.null(rownames(sources[[i]]))) {
test.actual <- nrow(sources[[i]])
test.unique <- length(unique(rownames(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source row names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source row name."))
}
}
if (!is.null(colnames(sources[[i]]))) {
test.actual <- ncol(sources[[i]])
test.unique <- length(unique(colnames(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source column names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source column name."))
}
}
}
else {
if (!is.null(names(sources[[i]]))) {
test.actual <- length(sources[[i]])
test.unique <- length(unique(names(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source name."))
}
}
}
}
for (i in 1:length(targets)) {
if (class(targets[[i]]) %in% c("matrix", "data.frame")) {
if (!is.null(rownames(targets[[i]]))) {
test.actual <- nrow(targets[[i]])
test.unique <- length(unique(rownames(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target row names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target row name."))
}
}
if (!is.null(colnames(targets[[i]]))) {
test.actual <- ncol(targets[[i]])
test.unique <- length(unique(colnames(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target column names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target column name."))
}
}
}
else {
if (!is.null(names(targets[[i]]))) {
test.actual <- length(targets[[i]])
test.unique <- length(unique(names(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target name."))
}
}
}
}
for (i in 1:length(sources)) {
if (sources.types[[i]] == "network" && !is.null(sources.matrices[[i]]) &&
length(sources.matrices[[i]]) > 0) {
for (j in 1:length(sources.matrices[[i]])) {
if (nrow(as.matrix(sources.matrices[[i]][[j]])) !=
nrow(as.matrix(sources[[i]])) || ncol(as.matrix(sources.matrices[[i]][[j]])) !=
ncol(as.matrix(sources[[i]]))) {
warning(paste("Network attribute", sources.matrixnames[[i]][j],
"does not have the same dimensions as the source network at",
"time step", i, "."))
}
if (class(sources.matrices[[i]][[j]]) == "network") {
if (sources.onemode[[i]] == TRUE) {
sources.matrices[[i]][[j]] <- set.vertex.attribute(sources.matrices[[i]][[j]],
"vertex.names", rownames(as.matrix(sources[[i]])))
}
else {
sources.matrices[[i]][[j]] <- set.vertex.attribute(sources.matrices[[i]][[j]],
"vertex.names", c(rownames(as.matrix(sources[[i]])),
colnames(as.matrix(sources[[i]]))))
}
}
else {
rownames(sources.matrices[[i]][[j]]) <- rownames(as.matrix(sources[[i]]))
colnames(sources.matrices[[i]][[j]]) <- colnames(as.matrix(sources[[i]]))
}
}
}
}
for (i in 1:length(sources)) {
if (!is.vector(sources[[i]]) && !class(sources[[i]]) %in%
c("matrix", "network")) {
stop(paste("Source item", i, "is not a matrix, network, or vector."))
}
if (!is.vector(targets[[i]]) && !class(targets[[i]]) %in%
c("matrix", "network")) {
stop(paste("Target item", i, "is not a matrix, network, or vector."))
}
add.row.labels <- character()
add.col.labels <- character()
if (add == TRUE) {
nr <- nrow(sources[[i]])
source.row.labels <- rownames(sources[[i]])
if (!sources.types[[i]] %in% c("matrix", "network")) {
source.col.labels <- rownames(sources[[i]])
}
else {
source.col.labels <- colnames(sources[[i]])
}
if (sources.types[[i]] %in% c("matrix", "network")) {
if (is.null(source.row.labels)) {
stop(paste0("The source at t = ", i, " does not contain any row labels."))
}
if (is.null(source.col.labels)) {
stop(paste0("The source at t = ", i, " does not contain any column labels."))
}
}
target.row.labels <- rownames(targets[[i]])
if (!targets.types[[i]] %in% c("matrix", "network")) {
target.col.labels <- rownames(targets[[i]])
}
else {
target.col.labels <- colnames(targets[[i]])
}
if (is.null(target.row.labels)) {
stop(paste0("The target at t = ", i, " does not contain any row labels."))
}
if (targets.types[[i]] %in% c("matrix", "network")) {
if (is.null(target.col.labels)) {
stop(paste0("The target at t = ", i, " does not contain any column labels."))
}
}
add.row.indices <- which(!target.row.labels %in%
source.row.labels)
add.row.labels <- target.row.labels[add.row.indices]
add.col.indices <- which(!target.col.labels %in%
source.col.labels)
add.col.labels <- target.col.labels[add.col.indices]
if (length(add.row.indices) > 0) {
for (j in 1:length(add.row.indices)) {
insert <- rep(value, ncol(sources[[i]]))
part1 <- sources[[i]][0:(add.row.indices[j] -
1), ]
if (class(part1) != "matrix") {
if (sources.types[[i]] %in% c("matrix", "network")) {
part1 <- matrix(part1, nrow = 1)
}
else {
part1 <- matrix(part1, ncol = 1)
}
}
rownames(part1) <- rownames(sources[[i]])[0:(add.row.indices[j] -
1)]
if (add.row.indices[j] <= nrow(sources[[i]])) {
part2 <- sources[[i]][add.row.indices[j]:nrow(sources[[i]]),
]
}
else {
part2 <- matrix(ncol = ncol(sources[[i]]),
nrow = 0)
}
if (class(part2) != "matrix") {
part2 <- matrix(part2, nrow = 1)
}
if (nrow(part2) > 0) {
rownames(part2) <- rownames(sources[[i]])[add.row.indices[j]:nrow(sources[[i]])]
sources[[i]] <- rbind(part1, insert, part2)
}
else {
sources[[i]] <- rbind(part1, insert)
}
rownames(sources[[i]])[add.row.indices[j]] <- add.row.labels[j]
if (sources.types[[i]] == "network" && sources.onemode[[i]] ==
TRUE) {
for (k in 1:length(sources.attributes[[i]])) {
at1 <- sources.attributes[[i]][[k]][0:(add.row.indices[j] -
1)]
at2 <- sources.attributes[[i]][[k]][add.row.indices[j]:length(sources.attributes[[i]][[k]])]
if (sources.attribnames[[i]][k] == "vertex.names") {
sources.attributes[[i]][[k]] <- c(at1,
add.row.labels[j], at2)
}
else if (sources.attribnames[[i]][k] ==
"na") {
sources.attributes[[i]][[k]] <- c(at1,
TRUE, at2)
}
else {
sources.attributes[[i]][[k]] <- c(at1,
value, at2)
}
}
}
}
}
if (length(add.col.indices) > 0 && sources.types[[i]] %in%
c("matrix", "network")) {
for (j in 1:length(add.col.indices)) {
insert <- rep(value, nrow(sources[[i]]))
part1 <- sources[[i]][, 0:(add.col.indices[j] -
1)]
if (class(part1) != "matrix") {
part1 <- matrix(part1, ncol = 1)
}
colnames(part1) <- colnames(sources[[i]])[0:(add.col.indices[j] -
1)]
if (add.col.indices[j] <= ncol(sources[[i]])) {
part2 <- sources[[i]][, add.col.indices[j]:ncol(sources[[i]])]
}
else {
part2 <- matrix(nrow = nrow(sources[[i]]),
ncol = 0)
}
if (class(part2) != "matrix") {
part2 <- matrix(part2, ncol = 1)
}
if (ncol(part2) > 0) {
colnames(part2) <- colnames(sources[[i]])[add.col.indices[j]:ncol(sources[[i]])]
sources[[i]] <- cbind(part1, insert, part2)
}
else {
sources[[i]] <- cbind(part1, insert)
}
colnames(sources[[i]])[add.col.indices[j]] <- add.col.labels[j]
}
}
if (sources.types[[i]] == "network" && sources.onemode[[i]] ==
FALSE) {
add.col.indices <- sapply(add.col.indices, function(x) x +
nr)
combined.indices <- c(add.row.indices, add.col.indices)
for (j in 1:length(sources.attributes[[i]])) {
if (length(combined.indices) > 0) {
for (k in 1:length(combined.indices)) {
at1 <- sources.attributes[[i]][[j]][0:(combined.indices[k] -
1)]
at2 <- sources.attributes[[i]][[j]][combined.indices[k]:length(sources.attributes[[i]][[j]])]
if (sources.attribnames[[i]][j] == "vertex.names") {
sources.attributes[[i]][[j]] <- c(at1,
add.col.labels[j], at2)
}
else if (sources.attribnames[[i]][j] ==
"na") {
sources.attributes[[i]][[j]] <- c(at1,
TRUE, at2)
}
else {
sources.attributes[[i]][[j]] <- c(at1,
value, at2)
}
}
}
}
}
}
removed.rows <- character()
removed.columns <- character()
if (remove == TRUE) {
nr <- nrow(sources[[i]])
source.row.labels <- rownames(sources[[i]])
if (!sources.types[[i]] %in% c("matrix", "network")) {
source.col.labels <- rownames(sources[[i]])
}
else {
source.col.labels <- colnames(sources[[i]])
}
if (sources.types[[i]] %in% c("matrix", "network")) {
if (nr == 0) {
stop(paste0("The source at t = ", i, " has no rows."))
}
if (is.null(source.row.labels)) {
stop(paste0("The source at t = ", i, " does not contain any row labels."))
}
if (is.null(source.col.labels)) {
stop(paste0("The source at t = ", i, " does not contain any column labels."))
}
}
target.row.labels <- rownames(targets[[i]])
if (!targets.types[[i]] %in% c("matrix", "network")) {
target.col.labels <- rownames(targets[[i]])
}
else {
target.col.labels <- colnames(targets[[i]])
}
if (targets.types[[i]] %in% c("matrix", "network")) {
if (is.null(target.row.labels)) {
stop(paste0("The target at t = ", i, " does not contain any row labels."))
}
if (is.null(target.col.labels)) {
stop(paste0("The target at t = ", i, " does not contain any column labels."))
}
}
source.row.labels <- rownames(sources[[i]])
source.col.labels <- colnames(sources[[i]])
target.row.labels <- rownames(targets[[i]])
target.col.labels <- colnames(targets[[i]])
keep.row.indices <- which(source.row.labels %in%
target.row.labels)
if (sources.types[[i]] %in% c("matrix", "network") &&
targets.types[[i]] %in% c("matrix", "network")) {
keep.col.indices <- which(source.col.labels %in%
target.col.labels)
}
else if (sources.types[[i]] %in% c("matrix", "network") &&
!targets.types[[i]] %in% c("matrix", "network")) {
if (sources.onemode[[i]] == TRUE) {
keep.col.indices <- keep.row.indices
}
else {
keep.col.indices <- 1:ncol(sources[[i]])
}
}
else {
keep.col.indices <- 1
}
removed.rows <- which(!1:nrow(as.matrix(sources[[i]])) %in%
keep.row.indices)
removed.columns <- which(!1:ncol(as.matrix(sources[[i]])) %in%
keep.col.indices)
sources[[i]] <- as.matrix(sources[[i]][keep.row.indices,
keep.col.indices])
if (sources.types[[i]] == "network") {
if (sources.onemode[[i]] == TRUE) {
for (j in 1:length(sources.attributes[[i]])) {
sources.attributes[[i]][[j]] <- sources.attributes[[i]][[j]][keep.row.indices]
}
}
else {
keep.col.indices <- sapply(keep.col.indices,
function(x) x + nr)
combined.indices <- c(keep.row.indices, keep.col.indices)
for (j in 1:length(sources.attributes[[i]])) {
sources.attributes[[i]][[j]] <- sources.attributes[[i]][[j]][combined.indices]
}
}
}
}
if (sources.types[[i]] %in% c("matrix", "network") &&
targets.types[[i]] %in% c("matrix", "network") &&
nrow(sources[[i]]) == nrow(targets[[i]]) && ncol(sources[[i]]) ==
ncol(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
colnames(targets[[i]])]
}
else if (sources.types[[i]] %in% c("matrix", "network") &&
!targets.types[[i]] %in% c("matrix", "network") &&
nrow(sources[[i]]) == nrow(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
rownames(targets[[i]])]
}
else if (length(sources[[i]]) == nrow(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
]
}
else if (add == FALSE && (nrow(sources[[i]]) < nrow(targets[[i]]) ||
any(rownames(sources[[i]]) != rownames(targets[[i]])))) {
}
if (sources.types[[i]] == "network") {
sources[[i]] <- network(sources[[i]], directed = sources.directed[[i]],
bipartite = !sources.onemode[[i]])
for (j in 1:length(sources.attribnames[[i]])) {
sources[[i]] <- set.vertex.attribute(sources[[i]],
sources.attribnames[[i]][j], sources.attributes[[i]][[j]])
}
}
if (!sources.types[[i]] %in% c("matrix", "network") &&
class(sources[[i]]) == "matrix" && ncol(sources[[i]]) ==
1) {
sources[[i]] <- sources[[i]][, 1]
}
if (returnlabels == TRUE) {
sources[[i]] <- list()
sources[[i]]$removed.row <- removed.rows
sources[[i]]$removed.col <- removed.columns
sources[[i]]$added.row <- add.row.labels
sources[[i]]$added.col <- add.col.labels
}
}
for (i in 1:length(sources)) {
if (sources.types[[i]] == "network" && !is.null(sources.matrixnames[[i]]) &&
length(sources.matrixnames[[i]]) > 0) {
for (j in 1:length(sources.matrixnames[[i]])) {
mat <- adjust(source = sources.matrices[[i]][[j]],
target = sources[[i]], add = add, remove = remove,
value = value)
set.network.attribute(sources[[i]], sources.matrixnames[[i]][j],
mat)
}
}
}
if (sources.initialtype == "list") {
return(sources)
}
else {
return(sources[[1]])
}
}
<bytecode: 0xa711f30>
<environment: namespace:xergm.common>
--- function search by body ---
Function adjust in namespace xergm.common has this body.
----------- END OF FAILURE REPORT --------------
Error in if (class(source) == "matrix") { : the condition has length > 1
Calls: adjust
Execution halted
Flavor: r-devel-linux-x86_64-debian-clang
Version: 1.7.7
Check: examples
Result: ERROR
Running examples in ‘xergm.common-Ex.R’ failed
The error most likely occurred in:
> base::assign(".ptime", proc.time(), pos = "CheckExEnv")
> ### Name: adjust
> ### Title: Adjust the dimensions of a matrix to the dimensions of another
> ### matrix
> ### Aliases: adjust
>
> ### ** Examples
>
> # create sociomatrix a with 13 vertices a to m
> vertices <- letters[1:13]
> a <- matrix(rbinom(length(vertices)^2, 1, 0.1), nrow = length(vertices))
> rownames(a) <- colnames(a) <- vertices
>
> # create sociomatrix b with the same vertices except f and k, but additional n
> vertices <- c(vertices[-c(6, 11)], "n")
> b <- matrix(rbinom(length(vertices)^2, 1, 0.1), nrow = length(vertices))
> rownames(b) <- colnames(b) <- vertices
>
> # check dimensions
> dim(a) # 13 x 13
[1] 13 13
> dim(b) # 12 x 12
[1] 12 12
>
> # adjust a to b: add n and fill up with NAs; remove f and k
> adjust(a, b, add = TRUE, remove = TRUE)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
xergm.common
--- call from context ---
adjust(a, b, add = TRUE, remove = TRUE)
--- call from argument ---
if (class(source) == "matrix") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "matrix"
} else if (class(source) == "network") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "network"
} else if (class(source) == "list") {
sources <- source
sources.initialtype <- "list"
} else if (is.vector(source)) {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "vector"
} else {
stop(paste("Source data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
--- R stacktrace ---
where 1: adjust(a, b, add = TRUE, remove = TRUE)
--- value of length: 2 type: logical ---
[1] TRUE FALSE
--- function from context ---
function (source, target, remove = TRUE, add = TRUE, value = NA,
returnlabels = FALSE)
{
if (is.null(source)) {
stop("The 'source' argument was not recognized.")
}
else if (class(source) == "matrix") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "matrix"
}
else if (class(source) == "network") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "network"
}
else if (class(source) == "list") {
sources <- source
sources.initialtype <- "list"
}
else if (is.vector(source)) {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "vector"
}
else {
stop(paste("Source data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
if (is.null(target)) {
stop("The 'target' argument was not recognized.")
}
else if (class(target) == "matrix") {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "matrix"
}
else if (class(target) == "network") {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "network"
}
else if (class(target) == "list") {
targets <- target
targets.initialtype <- "list"
}
else if (is.vector(target)) {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "vector"
}
else {
stop(paste("Target data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
if (length(sources) == length(targets)) {
}
else if (length(sources) == 1) {
for (i in 2:length(targets)) {
sources[[i]] <- sources[[1]]
}
}
else if (length(targets) == 1) {
for (i in 2:length(sources)) {
targets[[i]] <- targets[[1]]
}
}
else {
stop("Different numbers of sources and targets were provided.")
}
sources.attribnames <- list()
sources.attributes <- list()
sources.types <- list()
sources.onemode <- list()
sources.directed <- list()
sources.matrixnames <- list()
sources.matrices <- list()
targets.attribnames <- list()
targets.attributes <- list()
targets.types <- list()
targets.onemode <- list()
targets.directed <- list()
for (i in 1:length(sources)) {
sources.types[[i]] <- class(sources[[i]])
if (class(sources[[i]]) == "network") {
sources.attribnames[[i]] <- list.vertex.attributes(sources[[i]])
attributes <- list()
if (!is.null(sources.attribnames[[i]]) && length(sources.attribnames[[i]]) >
0) {
for (j in 1:length(sources.attribnames[[i]])) {
attributes[[j]] <- get.vertex.attribute(sources[[i]],
sources.attribnames[[i]][j])
}
}
sources.attributes[[i]] <- attributes
sources.onemode[[i]] <- !is.bipartite(sources[[i]])
sources.directed[[i]] <- is.directed(sources[[i]])
temp <- list.network.attributes(sources[[i]])
temp <- temp[!temp %in% c("bipartite", "directed",
"hyper", "loops", "mnext", "multiple", "n")]
if (length(temp) > 0) {
for (j in length(temp):1) {
if (!class(get.network.attribute(sources[[i]],
temp[j])) %in% c("network", "matrix", "Matrix")) {
temp <- temp[-j]
}
}
}
sources.matrixnames[[i]] <- temp
matrices <- list()
if (!is.null(sources.matrixnames[[i]]) && length(sources.matrixnames[[i]]) >
0) {
for (j in 1:length(sources.matrixnames[[i]])) {
matrices[[j]] <- get.network.attribute(sources[[i]],
sources.matrixnames[[i]][j])
}
}
sources.matrices[[i]] <- matrices
rm(temp)
sources[[i]] <- as.matrix(sources[[i]])
}
else if (class(sources[[i]]) == "matrix") {
sources.onemode[[i]] <- is.mat.onemode(sources[[i]])
sources.directed[[i]] <- is.mat.directed(sources[[i]])
}
else {
sources[[i]] <- as.matrix(sources[[i]], ncol = 1)
}
targets.types[[i]] <- class(targets[[i]])
if (class(targets[[i]]) == "network") {
targets.attribnames[[i]] <- list.vertex.attributes(targets[[i]])
attributes <- list()
if (!is.null(targets.attribnames[[i]]) && length(targets.attribnames[[i]]) >
0) {
for (j in 1:length(targets.attribnames[[i]])) {
attributes[[j]] <- get.vertex.attribute(targets[[i]],
targets.attribnames[[i]][j])
}
}
targets.attributes[[i]] <- attributes
targets.onemode[[i]] <- !is.bipartite(targets[[i]])
targets.directed[[i]] <- is.directed(targets[[i]])
targets[[i]] <- as.matrix(targets[[i]])
}
else if (class(targets[[i]]) == "matrix") {
targets.onemode[[i]] <- is.mat.onemode(targets[[i]])
targets.directed[[i]] <- is.mat.directed(targets[[i]])
}
else {
targets[[i]] <- as.matrix(targets[[i]], ncol = 1)
}
}
for (i in 1:length(sources)) {
if (is.null(rownames(sources[[i]])) && !is.null(colnames(sources[[i]])) &&
nrow(sources[[i]]) == ncol(sources[[i]])) {
rownames(sources[[i]]) <- colnames(sources[[i]])
}
if (is.null(colnames(sources[[i]])) && !is.null(rownames(sources[[i]])) &&
nrow(sources[[i]]) == ncol(sources[[i]])) {
colnames(sources[[i]]) <- rownames(sources[[i]])
}
if (is.null(rownames(targets[[i]])) && !is.null(colnames(targets[[i]])) &&
nrow(targets[[i]]) == ncol(targets[[i]])) {
rownames(targets[[i]]) <- colnames(targets[[i]])
}
if (is.null(colnames(targets[[i]])) && !is.null(rownames(targets[[i]])) &&
nrow(targets[[i]]) == ncol(targets[[i]])) {
colnames(targets[[i]]) <- rownames(targets[[i]])
}
}
for (i in 1:length(sources)) {
if (class(sources[[i]]) %in% c("matrix", "data.frame")) {
if (!is.null(rownames(sources[[i]]))) {
test.actual <- nrow(sources[[i]])
test.unique <- length(unique(rownames(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source row names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source row name."))
}
}
if (!is.null(colnames(sources[[i]]))) {
test.actual <- ncol(sources[[i]])
test.unique <- length(unique(colnames(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source column names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source column name."))
}
}
}
else {
if (!is.null(names(sources[[i]]))) {
test.actual <- length(sources[[i]])
test.unique <- length(unique(names(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source name."))
}
}
}
}
for (i in 1:length(targets)) {
if (class(targets[[i]]) %in% c("matrix", "data.frame")) {
if (!is.null(rownames(targets[[i]]))) {
test.actual <- nrow(targets[[i]])
test.unique <- length(unique(rownames(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target row names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target row name."))
}
}
if (!is.null(colnames(targets[[i]]))) {
test.actual <- ncol(targets[[i]])
test.unique <- length(unique(colnames(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target column names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target column name."))
}
}
}
else {
if (!is.null(names(targets[[i]]))) {
test.actual <- length(targets[[i]])
test.unique <- length(unique(names(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target name."))
}
}
}
}
for (i in 1:length(sources)) {
if (sources.types[[i]] == "network" && !is.null(sources.matrices[[i]]) &&
length(sources.matrices[[i]]) > 0) {
for (j in 1:length(sources.matrices[[i]])) {
if (nrow(as.matrix(sources.matrices[[i]][[j]])) !=
nrow(as.matrix(sources[[i]])) || ncol(as.matrix(sources.matrices[[i]][[j]])) !=
ncol(as.matrix(sources[[i]]))) {
warning(paste("Network attribute", sources.matrixnames[[i]][j],
"does not have the same dimensions as the source network at",
"time step", i, "."))
}
if (class(sources.matrices[[i]][[j]]) == "network") {
if (sources.onemode[[i]] == TRUE) {
sources.matrices[[i]][[j]] <- set.vertex.attribute(sources.matrices[[i]][[j]],
"vertex.names", rownames(as.matrix(sources[[i]])))
}
else {
sources.matrices[[i]][[j]] <- set.vertex.attribute(sources.matrices[[i]][[j]],
"vertex.names", c(rownames(as.matrix(sources[[i]])),
colnames(as.matrix(sources[[i]]))))
}
}
else {
rownames(sources.matrices[[i]][[j]]) <- rownames(as.matrix(sources[[i]]))
colnames(sources.matrices[[i]][[j]]) <- colnames(as.matrix(sources[[i]]))
}
}
}
}
for (i in 1:length(sources)) {
if (!is.vector(sources[[i]]) && !class(sources[[i]]) %in%
c("matrix", "network")) {
stop(paste("Source item", i, "is not a matrix, network, or vector."))
}
if (!is.vector(targets[[i]]) && !class(targets[[i]]) %in%
c("matrix", "network")) {
stop(paste("Target item", i, "is not a matrix, network, or vector."))
}
add.row.labels <- character()
add.col.labels <- character()
if (add == TRUE) {
nr <- nrow(sources[[i]])
source.row.labels <- rownames(sources[[i]])
if (!sources.types[[i]] %in% c("matrix", "network")) {
source.col.labels <- rownames(sources[[i]])
}
else {
source.col.labels <- colnames(sources[[i]])
}
if (sources.types[[i]] %in% c("matrix", "network")) {
if (is.null(source.row.labels)) {
stop(paste0("The source at t = ", i, " does not contain any row labels."))
}
if (is.null(source.col.labels)) {
stop(paste0("The source at t = ", i, " does not contain any column labels."))
}
}
target.row.labels <- rownames(targets[[i]])
if (!targets.types[[i]] %in% c("matrix", "network")) {
target.col.labels <- rownames(targets[[i]])
}
else {
target.col.labels <- colnames(targets[[i]])
}
if (is.null(target.row.labels)) {
stop(paste0("The target at t = ", i, " does not contain any row labels."))
}
if (targets.types[[i]] %in% c("matrix", "network")) {
if (is.null(target.col.labels)) {
stop(paste0("The target at t = ", i, " does not contain any column labels."))
}
}
add.row.indices <- which(!target.row.labels %in%
source.row.labels)
add.row.labels <- target.row.labels[add.row.indices]
add.col.indices <- which(!target.col.labels %in%
source.col.labels)
add.col.labels <- target.col.labels[add.col.indices]
if (length(add.row.indices) > 0) {
for (j in 1:length(add.row.indices)) {
insert <- rep(value, ncol(sources[[i]]))
part1 <- sources[[i]][0:(add.row.indices[j] -
1), ]
if (class(part1) != "matrix") {
if (sources.types[[i]] %in% c("matrix", "network")) {
part1 <- matrix(part1, nrow = 1)
}
else {
part1 <- matrix(part1, ncol = 1)
}
}
rownames(part1) <- rownames(sources[[i]])[0:(add.row.indices[j] -
1)]
if (add.row.indices[j] <= nrow(sources[[i]])) {
part2 <- sources[[i]][add.row.indices[j]:nrow(sources[[i]]),
]
}
else {
part2 <- matrix(ncol = ncol(sources[[i]]),
nrow = 0)
}
if (class(part2) != "matrix") {
part2 <- matrix(part2, nrow = 1)
}
if (nrow(part2) > 0) {
rownames(part2) <- rownames(sources[[i]])[add.row.indices[j]:nrow(sources[[i]])]
sources[[i]] <- rbind(part1, insert, part2)
}
else {
sources[[i]] <- rbind(part1, insert)
}
rownames(sources[[i]])[add.row.indices[j]] <- add.row.labels[j]
if (sources.types[[i]] == "network" && sources.onemode[[i]] ==
TRUE) {
for (k in 1:length(sources.attributes[[i]])) {
at1 <- sources.attributes[[i]][[k]][0:(add.row.indices[j] -
1)]
at2 <- sources.attributes[[i]][[k]][add.row.indices[j]:length(sources.attributes[[i]][[k]])]
if (sources.attribnames[[i]][k] == "vertex.names") {
sources.attributes[[i]][[k]] <- c(at1,
add.row.labels[j], at2)
}
else if (sources.attribnames[[i]][k] ==
"na") {
sources.attributes[[i]][[k]] <- c(at1,
TRUE, at2)
}
else {
sources.attributes[[i]][[k]] <- c(at1,
value, at2)
}
}
}
}
}
if (length(add.col.indices) > 0 && sources.types[[i]] %in%
c("matrix", "network")) {
for (j in 1:length(add.col.indices)) {
insert <- rep(value, nrow(sources[[i]]))
part1 <- sources[[i]][, 0:(add.col.indices[j] -
1)]
if (class(part1) != "matrix") {
part1 <- matrix(part1, ncol = 1)
}
colnames(part1) <- colnames(sources[[i]])[0:(add.col.indices[j] -
1)]
if (add.col.indices[j] <= ncol(sources[[i]])) {
part2 <- sources[[i]][, add.col.indices[j]:ncol(sources[[i]])]
}
else {
part2 <- matrix(nrow = nrow(sources[[i]]),
ncol = 0)
}
if (class(part2) != "matrix") {
part2 <- matrix(part2, ncol = 1)
}
if (ncol(part2) > 0) {
colnames(part2) <- colnames(sources[[i]])[add.col.indices[j]:ncol(sources[[i]])]
sources[[i]] <- cbind(part1, insert, part2)
}
else {
sources[[i]] <- cbind(part1, insert)
}
colnames(sources[[i]])[add.col.indices[j]] <- add.col.labels[j]
}
}
if (sources.types[[i]] == "network" && sources.onemode[[i]] ==
FALSE) {
add.col.indices <- sapply(add.col.indices, function(x) x +
nr)
combined.indices <- c(add.row.indices, add.col.indices)
for (j in 1:length(sources.attributes[[i]])) {
if (length(combined.indices) > 0) {
for (k in 1:length(combined.indices)) {
at1 <- sources.attributes[[i]][[j]][0:(combined.indices[k] -
1)]
at2 <- sources.attributes[[i]][[j]][combined.indices[k]:length(sources.attributes[[i]][[j]])]
if (sources.attribnames[[i]][j] == "vertex.names") {
sources.attributes[[i]][[j]] <- c(at1,
add.col.labels[j], at2)
}
else if (sources.attribnames[[i]][j] ==
"na") {
sources.attributes[[i]][[j]] <- c(at1,
TRUE, at2)
}
else {
sources.attributes[[i]][[j]] <- c(at1,
value, at2)
}
}
}
}
}
}
removed.rows <- character()
removed.columns <- character()
if (remove == TRUE) {
nr <- nrow(sources[[i]])
source.row.labels <- rownames(sources[[i]])
if (!sources.types[[i]] %in% c("matrix", "network")) {
source.col.labels <- rownames(sources[[i]])
}
else {
source.col.labels <- colnames(sources[[i]])
}
if (sources.types[[i]] %in% c("matrix", "network")) {
if (nr == 0) {
stop(paste0("The source at t = ", i, " has no rows."))
}
if (is.null(source.row.labels)) {
stop(paste0("The source at t = ", i, " does not contain any row labels."))
}
if (is.null(source.col.labels)) {
stop(paste0("The source at t = ", i, " does not contain any column labels."))
}
}
target.row.labels <- rownames(targets[[i]])
if (!targets.types[[i]] %in% c("matrix", "network")) {
target.col.labels <- rownames(targets[[i]])
}
else {
target.col.labels <- colnames(targets[[i]])
}
if (targets.types[[i]] %in% c("matrix", "network")) {
if (is.null(target.row.labels)) {
stop(paste0("The target at t = ", i, " does not contain any row labels."))
}
if (is.null(target.col.labels)) {
stop(paste0("The target at t = ", i, " does not contain any column labels."))
}
}
source.row.labels <- rownames(sources[[i]])
source.col.labels <- colnames(sources[[i]])
target.row.labels <- rownames(targets[[i]])
target.col.labels <- colnames(targets[[i]])
keep.row.indices <- which(source.row.labels %in%
target.row.labels)
if (sources.types[[i]] %in% c("matrix", "network") &&
targets.types[[i]] %in% c("matrix", "network")) {
keep.col.indices <- which(source.col.labels %in%
target.col.labels)
}
else if (sources.types[[i]] %in% c("matrix", "network") &&
!targets.types[[i]] %in% c("matrix", "network")) {
if (sources.onemode[[i]] == TRUE) {
keep.col.indices <- keep.row.indices
}
else {
keep.col.indices <- 1:ncol(sources[[i]])
}
}
else {
keep.col.indices <- 1
}
removed.rows <- which(!1:nrow(as.matrix(sources[[i]])) %in%
keep.row.indices)
removed.columns <- which(!1:ncol(as.matrix(sources[[i]])) %in%
keep.col.indices)
sources[[i]] <- as.matrix(sources[[i]][keep.row.indices,
keep.col.indices])
if (sources.types[[i]] == "network") {
if (sources.onemode[[i]] == TRUE) {
for (j in 1:length(sources.attributes[[i]])) {
sources.attributes[[i]][[j]] <- sources.attributes[[i]][[j]][keep.row.indices]
}
}
else {
keep.col.indices <- sapply(keep.col.indices,
function(x) x + nr)
combined.indices <- c(keep.row.indices, keep.col.indices)
for (j in 1:length(sources.attributes[[i]])) {
sources.attributes[[i]][[j]] <- sources.attributes[[i]][[j]][combined.indices]
}
}
}
}
if (sources.types[[i]] %in% c("matrix", "network") &&
targets.types[[i]] %in% c("matrix", "network") &&
nrow(sources[[i]]) == nrow(targets[[i]]) && ncol(sources[[i]]) ==
ncol(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
colnames(targets[[i]])]
}
else if (sources.types[[i]] %in% c("matrix", "network") &&
!targets.types[[i]] %in% c("matrix", "network") &&
nrow(sources[[i]]) == nrow(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
rownames(targets[[i]])]
}
else if (length(sources[[i]]) == nrow(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
]
}
else if (add == FALSE && (nrow(sources[[i]]) < nrow(targets[[i]]) ||
any(rownames(sources[[i]]) != rownames(targets[[i]])))) {
}
if (sources.types[[i]] == "network") {
sources[[i]] <- network(sources[[i]], directed = sources.directed[[i]],
bipartite = !sources.onemode[[i]])
for (j in 1:length(sources.attribnames[[i]])) {
sources[[i]] <- set.vertex.attribute(sources[[i]],
sources.attribnames[[i]][j], sources.attributes[[i]][[j]])
}
}
if (!sources.types[[i]] %in% c("matrix", "network") &&
class(sources[[i]]) == "matrix" && ncol(sources[[i]]) ==
1) {
sources[[i]] <- sources[[i]][, 1]
}
if (returnlabels == TRUE) {
sources[[i]] <- list()
sources[[i]]$removed.row <- removed.rows
sources[[i]]$removed.col <- removed.columns
sources[[i]]$added.row <- add.row.labels
sources[[i]]$added.col <- add.col.labels
}
}
for (i in 1:length(sources)) {
if (sources.types[[i]] == "network" && !is.null(sources.matrixnames[[i]]) &&
length(sources.matrixnames[[i]]) > 0) {
for (j in 1:length(sources.matrixnames[[i]])) {
mat <- adjust(source = sources.matrices[[i]][[j]],
target = sources[[i]], add = add, remove = remove,
value = value)
set.network.attribute(sources[[i]], sources.matrixnames[[i]][j],
mat)
}
}
}
if (sources.initialtype == "list") {
return(sources)
}
else {
return(sources[[1]])
}
}
<bytecode: 0x559295c857b8>
<environment: namespace:xergm.common>
--- function search by body ---
Function adjust in namespace xergm.common has this body.
----------- END OF FAILURE REPORT --------------
Error in if (class(source) == "matrix") { : the condition has length > 1
Calls: adjust
Execution halted
Flavor: r-devel-linux-x86_64-debian-gcc
Version: 1.7.7
Check: examples
Result: ERROR
Running examples in ‘xergm.common-Ex.R’ failed
The error most likely occurred in:
> ### Name: adjust
> ### Title: Adjust the dimensions of a matrix to the dimensions of another
> ### matrix
> ### Aliases: adjust
>
> ### ** Examples
>
> # create sociomatrix a with 13 vertices a to m
> vertices <- letters[1:13]
> a <- matrix(rbinom(length(vertices)^2, 1, 0.1), nrow = length(vertices))
> rownames(a) <- colnames(a) <- vertices
>
> # create sociomatrix b with the same vertices except f and k, but additional n
> vertices <- c(vertices[-c(6, 11)], "n")
> b <- matrix(rbinom(length(vertices)^2, 1, 0.1), nrow = length(vertices))
> rownames(b) <- colnames(b) <- vertices
>
> # check dimensions
> dim(a) # 13 x 13
[1] 13 13
> dim(b) # 12 x 12
[1] 12 12
>
> # adjust a to b: add n and fill up with NAs; remove f and k
> adjust(a, b, add = TRUE, remove = TRUE)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
xergm.common
--- call from context ---
adjust(a, b, add = TRUE, remove = TRUE)
--- call from argument ---
if (class(source) == "matrix") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "matrix"
} else if (class(source) == "network") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "network"
} else if (class(source) == "list") {
sources <- source
sources.initialtype <- "list"
} else if (is.vector(source)) {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "vector"
} else {
stop(paste("Source data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
--- R stacktrace ---
where 1: adjust(a, b, add = TRUE, remove = TRUE)
--- value of length: 2 type: logical ---
[1] TRUE FALSE
--- function from context ---
function (source, target, remove = TRUE, add = TRUE, value = NA,
returnlabels = FALSE)
{
if (is.null(source)) {
stop("The 'source' argument was not recognized.")
}
else if (class(source) == "matrix") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "matrix"
}
else if (class(source) == "network") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "network"
}
else if (class(source) == "list") {
sources <- source
sources.initialtype <- "list"
}
else if (is.vector(source)) {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "vector"
}
else {
stop(paste("Source data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
if (is.null(target)) {
stop("The 'target' argument was not recognized.")
}
else if (class(target) == "matrix") {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "matrix"
}
else if (class(target) == "network") {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "network"
}
else if (class(target) == "list") {
targets <- target
targets.initialtype <- "list"
}
else if (is.vector(target)) {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "vector"
}
else {
stop(paste("Target data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
if (length(sources) == length(targets)) {
}
else if (length(sources) == 1) {
for (i in 2:length(targets)) {
sources[[i]] <- sources[[1]]
}
}
else if (length(targets) == 1) {
for (i in 2:length(sources)) {
targets[[i]] <- targets[[1]]
}
}
else {
stop("Different numbers of sources and targets were provided.")
}
sources.attribnames <- list()
sources.attributes <- list()
sources.types <- list()
sources.onemode <- list()
sources.directed <- list()
sources.matrixnames <- list()
sources.matrices <- list()
targets.attribnames <- list()
targets.attributes <- list()
targets.types <- list()
targets.onemode <- list()
targets.directed <- list()
for (i in 1:length(sources)) {
sources.types[[i]] <- class(sources[[i]])
if (class(sources[[i]]) == "network") {
sources.attribnames[[i]] <- list.vertex.attributes(sources[[i]])
attributes <- list()
if (!is.null(sources.attribnames[[i]]) && length(sources.attribnames[[i]]) >
0) {
for (j in 1:length(sources.attribnames[[i]])) {
attributes[[j]] <- get.vertex.attribute(sources[[i]],
sources.attribnames[[i]][j])
}
}
sources.attributes[[i]] <- attributes
sources.onemode[[i]] <- !is.bipartite(sources[[i]])
sources.directed[[i]] <- is.directed(sources[[i]])
temp <- list.network.attributes(sources[[i]])
temp <- temp[!temp %in% c("bipartite", "directed",
"hyper", "loops", "mnext", "multiple", "n")]
if (length(temp) > 0) {
for (j in length(temp):1) {
if (!class(get.network.attribute(sources[[i]],
temp[j])) %in% c("network", "matrix", "Matrix")) {
temp <- temp[-j]
}
}
}
sources.matrixnames[[i]] <- temp
matrices <- list()
if (!is.null(sources.matrixnames[[i]]) && length(sources.matrixnames[[i]]) >
0) {
for (j in 1:length(sources.matrixnames[[i]])) {
matrices[[j]] <- get.network.attribute(sources[[i]],
sources.matrixnames[[i]][j])
}
}
sources.matrices[[i]] <- matrices
rm(temp)
sources[[i]] <- as.matrix(sources[[i]])
}
else if (class(sources[[i]]) == "matrix") {
sources.onemode[[i]] <- is.mat.onemode(sources[[i]])
sources.directed[[i]] <- is.mat.directed(sources[[i]])
}
else {
sources[[i]] <- as.matrix(sources[[i]], ncol = 1)
}
targets.types[[i]] <- class(targets[[i]])
if (class(targets[[i]]) == "network") {
targets.attribnames[[i]] <- list.vertex.attributes(targets[[i]])
attributes <- list()
if (!is.null(targets.attribnames[[i]]) && length(targets.attribnames[[i]]) >
0) {
for (j in 1:length(targets.attribnames[[i]])) {
attributes[[j]] <- get.vertex.attribute(targets[[i]],
targets.attribnames[[i]][j])
}
}
targets.attributes[[i]] <- attributes
targets.onemode[[i]] <- !is.bipartite(targets[[i]])
targets.directed[[i]] <- is.directed(targets[[i]])
targets[[i]] <- as.matrix(targets[[i]])
}
else if (class(targets[[i]]) == "matrix") {
targets.onemode[[i]] <- is.mat.onemode(targets[[i]])
targets.directed[[i]] <- is.mat.directed(targets[[i]])
}
else {
targets[[i]] <- as.matrix(targets[[i]], ncol = 1)
}
}
for (i in 1:length(sources)) {
if (is.null(rownames(sources[[i]])) && !is.null(colnames(sources[[i]])) &&
nrow(sources[[i]]) == ncol(sources[[i]])) {
rownames(sources[[i]]) <- colnames(sources[[i]])
}
if (is.null(colnames(sources[[i]])) && !is.null(rownames(sources[[i]])) &&
nrow(sources[[i]]) == ncol(sources[[i]])) {
colnames(sources[[i]]) <- rownames(sources[[i]])
}
if (is.null(rownames(targets[[i]])) && !is.null(colnames(targets[[i]])) &&
nrow(targets[[i]]) == ncol(targets[[i]])) {
rownames(targets[[i]]) <- colnames(targets[[i]])
}
if (is.null(colnames(targets[[i]])) && !is.null(rownames(targets[[i]])) &&
nrow(targets[[i]]) == ncol(targets[[i]])) {
colnames(targets[[i]]) <- rownames(targets[[i]])
}
}
for (i in 1:length(sources)) {
if (class(sources[[i]]) %in% c("matrix", "data.frame")) {
if (!is.null(rownames(sources[[i]]))) {
test.actual <- nrow(sources[[i]])
test.unique <- length(unique(rownames(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source row names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source row name."))
}
}
if (!is.null(colnames(sources[[i]]))) {
test.actual <- ncol(sources[[i]])
test.unique <- length(unique(colnames(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source column names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source column name."))
}
}
}
else {
if (!is.null(names(sources[[i]]))) {
test.actual <- length(sources[[i]])
test.unique <- length(unique(names(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source name."))
}
}
}
}
for (i in 1:length(targets)) {
if (class(targets[[i]]) %in% c("matrix", "data.frame")) {
if (!is.null(rownames(targets[[i]]))) {
test.actual <- nrow(targets[[i]])
test.unique <- length(unique(rownames(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target row names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target row name."))
}
}
if (!is.null(colnames(targets[[i]]))) {
test.actual <- ncol(targets[[i]])
test.unique <- length(unique(colnames(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target column names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target column name."))
}
}
}
else {
if (!is.null(names(targets[[i]]))) {
test.actual <- length(targets[[i]])
test.unique <- length(unique(names(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target name."))
}
}
}
}
for (i in 1:length(sources)) {
if (sources.types[[i]] == "network" && !is.null(sources.matrices[[i]]) &&
length(sources.matrices[[i]]) > 0) {
for (j in 1:length(sources.matrices[[i]])) {
if (nrow(as.matrix(sources.matrices[[i]][[j]])) !=
nrow(as.matrix(sources[[i]])) || ncol(as.matrix(sources.matrices[[i]][[j]])) !=
ncol(as.matrix(sources[[i]]))) {
warning(paste("Network attribute", sources.matrixnames[[i]][j],
"does not have the same dimensions as the source network at",
"time step", i, "."))
}
if (class(sources.matrices[[i]][[j]]) == "network") {
if (sources.onemode[[i]] == TRUE) {
sources.matrices[[i]][[j]] <- set.vertex.attribute(sources.matrices[[i]][[j]],
"vertex.names", rownames(as.matrix(sources[[i]])))
}
else {
sources.matrices[[i]][[j]] <- set.vertex.attribute(sources.matrices[[i]][[j]],
"vertex.names", c(rownames(as.matrix(sources[[i]])),
colnames(as.matrix(sources[[i]]))))
}
}
else {
rownames(sources.matrices[[i]][[j]]) <- rownames(as.matrix(sources[[i]]))
colnames(sources.matrices[[i]][[j]]) <- colnames(as.matrix(sources[[i]]))
}
}
}
}
for (i in 1:length(sources)) {
if (!is.vector(sources[[i]]) && !class(sources[[i]]) %in%
c("matrix", "network")) {
stop(paste("Source item", i, "is not a matrix, network, or vector."))
}
if (!is.vector(targets[[i]]) && !class(targets[[i]]) %in%
c("matrix", "network")) {
stop(paste("Target item", i, "is not a matrix, network, or vector."))
}
add.row.labels <- character()
add.col.labels <- character()
if (add == TRUE) {
nr <- nrow(sources[[i]])
source.row.labels <- rownames(sources[[i]])
if (!sources.types[[i]] %in% c("matrix", "network")) {
source.col.labels <- rownames(sources[[i]])
}
else {
source.col.labels <- colnames(sources[[i]])
}
if (sources.types[[i]] %in% c("matrix", "network")) {
if (is.null(source.row.labels)) {
stop(paste0("The source at t = ", i, " does not contain any row labels."))
}
if (is.null(source.col.labels)) {
stop(paste0("The source at t = ", i, " does not contain any column labels."))
}
}
target.row.labels <- rownames(targets[[i]])
if (!targets.types[[i]] %in% c("matrix", "network")) {
target.col.labels <- rownames(targets[[i]])
}
else {
target.col.labels <- colnames(targets[[i]])
}
if (is.null(target.row.labels)) {
stop(paste0("The target at t = ", i, " does not contain any row labels."))
}
if (targets.types[[i]] %in% c("matrix", "network")) {
if (is.null(target.col.labels)) {
stop(paste0("The target at t = ", i, " does not contain any column labels."))
}
}
add.row.indices <- which(!target.row.labels %in%
source.row.labels)
add.row.labels <- target.row.labels[add.row.indices]
add.col.indices <- which(!target.col.labels %in%
source.col.labels)
add.col.labels <- target.col.labels[add.col.indices]
if (length(add.row.indices) > 0) {
for (j in 1:length(add.row.indices)) {
insert <- rep(value, ncol(sources[[i]]))
part1 <- sources[[i]][0:(add.row.indices[j] -
1), ]
if (class(part1) != "matrix") {
if (sources.types[[i]] %in% c("matrix", "network")) {
part1 <- matrix(part1, nrow = 1)
}
else {
part1 <- matrix(part1, ncol = 1)
}
}
rownames(part1) <- rownames(sources[[i]])[0:(add.row.indices[j] -
1)]
if (add.row.indices[j] <= nrow(sources[[i]])) {
part2 <- sources[[i]][add.row.indices[j]:nrow(sources[[i]]),
]
}
else {
part2 <- matrix(ncol = ncol(sources[[i]]),
nrow = 0)
}
if (class(part2) != "matrix") {
part2 <- matrix(part2, nrow = 1)
}
if (nrow(part2) > 0) {
rownames(part2) <- rownames(sources[[i]])[add.row.indices[j]:nrow(sources[[i]])]
sources[[i]] <- rbind(part1, insert, part2)
}
else {
sources[[i]] <- rbind(part1, insert)
}
rownames(sources[[i]])[add.row.indices[j]] <- add.row.labels[j]
if (sources.types[[i]] == "network" && sources.onemode[[i]] ==
TRUE) {
for (k in 1:length(sources.attributes[[i]])) {
at1 <- sources.attributes[[i]][[k]][0:(add.row.indices[j] -
1)]
at2 <- sources.attributes[[i]][[k]][add.row.indices[j]:length(sources.attributes[[i]][[k]])]
if (sources.attribnames[[i]][k] == "vertex.names") {
sources.attributes[[i]][[k]] <- c(at1,
add.row.labels[j], at2)
}
else if (sources.attribnames[[i]][k] ==
"na") {
sources.attributes[[i]][[k]] <- c(at1,
TRUE, at2)
}
else {
sources.attributes[[i]][[k]] <- c(at1,
value, at2)
}
}
}
}
}
if (length(add.col.indices) > 0 && sources.types[[i]] %in%
c("matrix", "network")) {
for (j in 1:length(add.col.indices)) {
insert <- rep(value, nrow(sources[[i]]))
part1 <- sources[[i]][, 0:(add.col.indices[j] -
1)]
if (class(part1) != "matrix") {
part1 <- matrix(part1, ncol = 1)
}
colnames(part1) <- colnames(sources[[i]])[0:(add.col.indices[j] -
1)]
if (add.col.indices[j] <= ncol(sources[[i]])) {
part2 <- sources[[i]][, add.col.indices[j]:ncol(sources[[i]])]
}
else {
part2 <- matrix(nrow = nrow(sources[[i]]),
ncol = 0)
}
if (class(part2) != "matrix") {
part2 <- matrix(part2, ncol = 1)
}
if (ncol(part2) > 0) {
colnames(part2) <- colnames(sources[[i]])[add.col.indices[j]:ncol(sources[[i]])]
sources[[i]] <- cbind(part1, insert, part2)
}
else {
sources[[i]] <- cbind(part1, insert)
}
colnames(sources[[i]])[add.col.indices[j]] <- add.col.labels[j]
}
}
if (sources.types[[i]] == "network" && sources.onemode[[i]] ==
FALSE) {
add.col.indices <- sapply(add.col.indices, function(x) x +
nr)
combined.indices <- c(add.row.indices, add.col.indices)
for (j in 1:length(sources.attributes[[i]])) {
if (length(combined.indices) > 0) {
for (k in 1:length(combined.indices)) {
at1 <- sources.attributes[[i]][[j]][0:(combined.indices[k] -
1)]
at2 <- sources.attributes[[i]][[j]][combined.indices[k]:length(sources.attributes[[i]][[j]])]
if (sources.attribnames[[i]][j] == "vertex.names") {
sources.attributes[[i]][[j]] <- c(at1,
add.col.labels[j], at2)
}
else if (sources.attribnames[[i]][j] ==
"na") {
sources.attributes[[i]][[j]] <- c(at1,
TRUE, at2)
}
else {
sources.attributes[[i]][[j]] <- c(at1,
value, at2)
}
}
}
}
}
}
removed.rows <- character()
removed.columns <- character()
if (remove == TRUE) {
nr <- nrow(sources[[i]])
source.row.labels <- rownames(sources[[i]])
if (!sources.types[[i]] %in% c("matrix", "network")) {
source.col.labels <- rownames(sources[[i]])
}
else {
source.col.labels <- colnames(sources[[i]])
}
if (sources.types[[i]] %in% c("matrix", "network")) {
if (nr == 0) {
stop(paste0("The source at t = ", i, " has no rows."))
}
if (is.null(source.row.labels)) {
stop(paste0("The source at t = ", i, " does not contain any row labels."))
}
if (is.null(source.col.labels)) {
stop(paste0("The source at t = ", i, " does not contain any column labels."))
}
}
target.row.labels <- rownames(targets[[i]])
if (!targets.types[[i]] %in% c("matrix", "network")) {
target.col.labels <- rownames(targets[[i]])
}
else {
target.col.labels <- colnames(targets[[i]])
}
if (targets.types[[i]] %in% c("matrix", "network")) {
if (is.null(target.row.labels)) {
stop(paste0("The target at t = ", i, " does not contain any row labels."))
}
if (is.null(target.col.labels)) {
stop(paste0("The target at t = ", i, " does not contain any column labels."))
}
}
source.row.labels <- rownames(sources[[i]])
source.col.labels <- colnames(sources[[i]])
target.row.labels <- rownames(targets[[i]])
target.col.labels <- colnames(targets[[i]])
keep.row.indices <- which(source.row.labels %in%
target.row.labels)
if (sources.types[[i]] %in% c("matrix", "network") &&
targets.types[[i]] %in% c("matrix", "network")) {
keep.col.indices <- which(source.col.labels %in%
target.col.labels)
}
else if (sources.types[[i]] %in% c("matrix", "network") &&
!targets.types[[i]] %in% c("matrix", "network")) {
if (sources.onemode[[i]] == TRUE) {
keep.col.indices <- keep.row.indices
}
else {
keep.col.indices <- 1:ncol(sources[[i]])
}
}
else {
keep.col.indices <- 1
}
removed.rows <- which(!1:nrow(as.matrix(sources[[i]])) %in%
keep.row.indices)
removed.columns <- which(!1:ncol(as.matrix(sources[[i]])) %in%
keep.col.indices)
sources[[i]] <- as.matrix(sources[[i]][keep.row.indices,
keep.col.indices])
if (sources.types[[i]] == "network") {
if (sources.onemode[[i]] == TRUE) {
for (j in 1:length(sources.attributes[[i]])) {
sources.attributes[[i]][[j]] <- sources.attributes[[i]][[j]][keep.row.indices]
}
}
else {
keep.col.indices <- sapply(keep.col.indices,
function(x) x + nr)
combined.indices <- c(keep.row.indices, keep.col.indices)
for (j in 1:length(sources.attributes[[i]])) {
sources.attributes[[i]][[j]] <- sources.attributes[[i]][[j]][combined.indices]
}
}
}
}
if (sources.types[[i]] %in% c("matrix", "network") &&
targets.types[[i]] %in% c("matrix", "network") &&
nrow(sources[[i]]) == nrow(targets[[i]]) && ncol(sources[[i]]) ==
ncol(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
colnames(targets[[i]])]
}
else if (sources.types[[i]] %in% c("matrix", "network") &&
!targets.types[[i]] %in% c("matrix", "network") &&
nrow(sources[[i]]) == nrow(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
rownames(targets[[i]])]
}
else if (length(sources[[i]]) == nrow(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
]
}
else if (add == FALSE && (nrow(sources[[i]]) < nrow(targets[[i]]) ||
any(rownames(sources[[i]]) != rownames(targets[[i]])))) {
}
if (sources.types[[i]] == "network") {
sources[[i]] <- network(sources[[i]], directed = sources.directed[[i]],
bipartite = !sources.onemode[[i]])
for (j in 1:length(sources.attribnames[[i]])) {
sources[[i]] <- set.vertex.attribute(sources[[i]],
sources.attribnames[[i]][j], sources.attributes[[i]][[j]])
}
}
if (!sources.types[[i]] %in% c("matrix", "network") &&
class(sources[[i]]) == "matrix" && ncol(sources[[i]]) ==
1) {
sources[[i]] <- sources[[i]][, 1]
}
if (returnlabels == TRUE) {
sources[[i]] <- list()
sources[[i]]$removed.row <- removed.rows
sources[[i]]$removed.col <- removed.columns
sources[[i]]$added.row <- add.row.labels
sources[[i]]$added.col <- add.col.labels
}
}
for (i in 1:length(sources)) {
if (sources.types[[i]] == "network" && !is.null(sources.matrixnames[[i]]) &&
length(sources.matrixnames[[i]]) > 0) {
for (j in 1:length(sources.matrixnames[[i]])) {
mat <- adjust(source = sources.matrices[[i]][[j]],
target = sources[[i]], add = add, remove = remove,
value = value)
set.network.attribute(sources[[i]], sources.matrixnames[[i]][j],
mat)
}
}
}
if (sources.initialtype == "list") {
return(sources)
}
else {
return(sources[[1]])
}
}
<bytecode: 0xafb9698>
<environment: namespace:xergm.common>
--- function search by body ---
Function adjust in namespace xergm.common has this body.
----------- END OF FAILURE REPORT --------------
Error in if (class(source) == "matrix") { : the condition has length > 1
Calls: adjust
Execution halted
Flavor: r-devel-linux-x86_64-fedora-clang
Version: 1.7.7
Check: examples
Result: ERROR
Running examples in ‘xergm.common-Ex.R’ failed
The error most likely occurred in:
> ### Name: adjust
> ### Title: Adjust the dimensions of a matrix to the dimensions of another
> ### matrix
> ### Aliases: adjust
>
> ### ** Examples
>
> # create sociomatrix a with 13 vertices a to m
> vertices <- letters[1:13]
> a <- matrix(rbinom(length(vertices)^2, 1, 0.1), nrow = length(vertices))
> rownames(a) <- colnames(a) <- vertices
>
> # create sociomatrix b with the same vertices except f and k, but additional n
> vertices <- c(vertices[-c(6, 11)], "n")
> b <- matrix(rbinom(length(vertices)^2, 1, 0.1), nrow = length(vertices))
> rownames(b) <- colnames(b) <- vertices
>
> # check dimensions
> dim(a) # 13 x 13
[1] 13 13
> dim(b) # 12 x 12
[1] 12 12
>
> # adjust a to b: add n and fill up with NAs; remove f and k
> adjust(a, b, add = TRUE, remove = TRUE)
----------- FAILURE REPORT --------------
--- failure: the condition has length > 1 ---
--- srcref ---
:
--- package (from environment) ---
xergm.common
--- call from context ---
adjust(a, b, add = TRUE, remove = TRUE)
--- call from argument ---
if (class(source) == "matrix") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "matrix"
} else if (class(source) == "network") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "network"
} else if (class(source) == "list") {
sources <- source
sources.initialtype <- "list"
} else if (is.vector(source)) {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "vector"
} else {
stop(paste("Source data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
--- R stacktrace ---
where 1: adjust(a, b, add = TRUE, remove = TRUE)
--- value of length: 2 type: logical ---
[1] TRUE FALSE
--- function from context ---
function (source, target, remove = TRUE, add = TRUE, value = NA,
returnlabels = FALSE)
{
if (is.null(source)) {
stop("The 'source' argument was not recognized.")
}
else if (class(source) == "matrix") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "matrix"
}
else if (class(source) == "network") {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "network"
}
else if (class(source) == "list") {
sources <- source
sources.initialtype <- "list"
}
else if (is.vector(source)) {
sources <- list()
sources[[1]] <- source
sources.initialtype <- "vector"
}
else {
stop(paste("Source data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
if (is.null(target)) {
stop("The 'target' argument was not recognized.")
}
else if (class(target) == "matrix") {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "matrix"
}
else if (class(target) == "network") {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "network"
}
else if (class(target) == "list") {
targets <- target
targets.initialtype <- "list"
}
else if (is.vector(target)) {
targets <- list()
targets[[1]] <- target
targets.initialtype <- "vector"
}
else {
stop(paste("Target data type not supported. Supported types are 'matrix',",
"'network', and 'list' objects and vectors."))
}
if (length(sources) == length(targets)) {
}
else if (length(sources) == 1) {
for (i in 2:length(targets)) {
sources[[i]] <- sources[[1]]
}
}
else if (length(targets) == 1) {
for (i in 2:length(sources)) {
targets[[i]] <- targets[[1]]
}
}
else {
stop("Different numbers of sources and targets were provided.")
}
sources.attribnames <- list()
sources.attributes <- list()
sources.types <- list()
sources.onemode <- list()
sources.directed <- list()
sources.matrixnames <- list()
sources.matrices <- list()
targets.attribnames <- list()
targets.attributes <- list()
targets.types <- list()
targets.onemode <- list()
targets.directed <- list()
for (i in 1:length(sources)) {
sources.types[[i]] <- class(sources[[i]])
if (class(sources[[i]]) == "network") {
sources.attribnames[[i]] <- list.vertex.attributes(sources[[i]])
attributes <- list()
if (!is.null(sources.attribnames[[i]]) && length(sources.attribnames[[i]]) >
0) {
for (j in 1:length(sources.attribnames[[i]])) {
attributes[[j]] <- get.vertex.attribute(sources[[i]],
sources.attribnames[[i]][j])
}
}
sources.attributes[[i]] <- attributes
sources.onemode[[i]] <- !is.bipartite(sources[[i]])
sources.directed[[i]] <- is.directed(sources[[i]])
temp <- list.network.attributes(sources[[i]])
temp <- temp[!temp %in% c("bipartite", "directed",
"hyper", "loops", "mnext", "multiple", "n")]
if (length(temp) > 0) {
for (j in length(temp):1) {
if (!class(get.network.attribute(sources[[i]],
temp[j])) %in% c("network", "matrix", "Matrix")) {
temp <- temp[-j]
}
}
}
sources.matrixnames[[i]] <- temp
matrices <- list()
if (!is.null(sources.matrixnames[[i]]) && length(sources.matrixnames[[i]]) >
0) {
for (j in 1:length(sources.matrixnames[[i]])) {
matrices[[j]] <- get.network.attribute(sources[[i]],
sources.matrixnames[[i]][j])
}
}
sources.matrices[[i]] <- matrices
rm(temp)
sources[[i]] <- as.matrix(sources[[i]])
}
else if (class(sources[[i]]) == "matrix") {
sources.onemode[[i]] <- is.mat.onemode(sources[[i]])
sources.directed[[i]] <- is.mat.directed(sources[[i]])
}
else {
sources[[i]] <- as.matrix(sources[[i]], ncol = 1)
}
targets.types[[i]] <- class(targets[[i]])
if (class(targets[[i]]) == "network") {
targets.attribnames[[i]] <- list.vertex.attributes(targets[[i]])
attributes <- list()
if (!is.null(targets.attribnames[[i]]) && length(targets.attribnames[[i]]) >
0) {
for (j in 1:length(targets.attribnames[[i]])) {
attributes[[j]] <- get.vertex.attribute(targets[[i]],
targets.attribnames[[i]][j])
}
}
targets.attributes[[i]] <- attributes
targets.onemode[[i]] <- !is.bipartite(targets[[i]])
targets.directed[[i]] <- is.directed(targets[[i]])
targets[[i]] <- as.matrix(targets[[i]])
}
else if (class(targets[[i]]) == "matrix") {
targets.onemode[[i]] <- is.mat.onemode(targets[[i]])
targets.directed[[i]] <- is.mat.directed(targets[[i]])
}
else {
targets[[i]] <- as.matrix(targets[[i]], ncol = 1)
}
}
for (i in 1:length(sources)) {
if (is.null(rownames(sources[[i]])) && !is.null(colnames(sources[[i]])) &&
nrow(sources[[i]]) == ncol(sources[[i]])) {
rownames(sources[[i]]) <- colnames(sources[[i]])
}
if (is.null(colnames(sources[[i]])) && !is.null(rownames(sources[[i]])) &&
nrow(sources[[i]]) == ncol(sources[[i]])) {
colnames(sources[[i]]) <- rownames(sources[[i]])
}
if (is.null(rownames(targets[[i]])) && !is.null(colnames(targets[[i]])) &&
nrow(targets[[i]]) == ncol(targets[[i]])) {
rownames(targets[[i]]) <- colnames(targets[[i]])
}
if (is.null(colnames(targets[[i]])) && !is.null(rownames(targets[[i]])) &&
nrow(targets[[i]]) == ncol(targets[[i]])) {
colnames(targets[[i]]) <- rownames(targets[[i]])
}
}
for (i in 1:length(sources)) {
if (class(sources[[i]]) %in% c("matrix", "data.frame")) {
if (!is.null(rownames(sources[[i]]))) {
test.actual <- nrow(sources[[i]])
test.unique <- length(unique(rownames(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source row names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source row name."))
}
}
if (!is.null(colnames(sources[[i]]))) {
test.actual <- ncol(sources[[i]])
test.unique <- length(unique(colnames(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source column names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source column name."))
}
}
}
else {
if (!is.null(names(sources[[i]]))) {
test.actual <- length(sources[[i]])
test.unique <- length(unique(names(sources[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate source names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate source name."))
}
}
}
}
for (i in 1:length(targets)) {
if (class(targets[[i]]) %in% c("matrix", "data.frame")) {
if (!is.null(rownames(targets[[i]]))) {
test.actual <- nrow(targets[[i]])
test.unique <- length(unique(rownames(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target row names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target row name."))
}
}
if (!is.null(colnames(targets[[i]]))) {
test.actual <- ncol(targets[[i]])
test.unique <- length(unique(colnames(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target column names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target column name."))
}
}
}
else {
if (!is.null(names(targets[[i]]))) {
test.actual <- length(targets[[i]])
test.unique <- length(unique(names(targets[[i]])))
dif <- test.actual - test.unique
if (dif > 1) {
stop(paste0("At t = ", i, ", there are ", dif,
" duplicate target names."))
}
else if (dif == 1) {
stop(paste0("At t = ", i, ", there is ", dif,
" duplicate target name."))
}
}
}
}
for (i in 1:length(sources)) {
if (sources.types[[i]] == "network" && !is.null(sources.matrices[[i]]) &&
length(sources.matrices[[i]]) > 0) {
for (j in 1:length(sources.matrices[[i]])) {
if (nrow(as.matrix(sources.matrices[[i]][[j]])) !=
nrow(as.matrix(sources[[i]])) || ncol(as.matrix(sources.matrices[[i]][[j]])) !=
ncol(as.matrix(sources[[i]]))) {
warning(paste("Network attribute", sources.matrixnames[[i]][j],
"does not have the same dimensions as the source network at",
"time step", i, "."))
}
if (class(sources.matrices[[i]][[j]]) == "network") {
if (sources.onemode[[i]] == TRUE) {
sources.matrices[[i]][[j]] <- set.vertex.attribute(sources.matrices[[i]][[j]],
"vertex.names", rownames(as.matrix(sources[[i]])))
}
else {
sources.matrices[[i]][[j]] <- set.vertex.attribute(sources.matrices[[i]][[j]],
"vertex.names", c(rownames(as.matrix(sources[[i]])),
colnames(as.matrix(sources[[i]]))))
}
}
else {
rownames(sources.matrices[[i]][[j]]) <- rownames(as.matrix(sources[[i]]))
colnames(sources.matrices[[i]][[j]]) <- colnames(as.matrix(sources[[i]]))
}
}
}
}
for (i in 1:length(sources)) {
if (!is.vector(sources[[i]]) && !class(sources[[i]]) %in%
c("matrix", "network")) {
stop(paste("Source item", i, "is not a matrix, network, or vector."))
}
if (!is.vector(targets[[i]]) && !class(targets[[i]]) %in%
c("matrix", "network")) {
stop(paste("Target item", i, "is not a matrix, network, or vector."))
}
add.row.labels <- character()
add.col.labels <- character()
if (add == TRUE) {
nr <- nrow(sources[[i]])
source.row.labels <- rownames(sources[[i]])
if (!sources.types[[i]] %in% c("matrix", "network")) {
source.col.labels <- rownames(sources[[i]])
}
else {
source.col.labels <- colnames(sources[[i]])
}
if (sources.types[[i]] %in% c("matrix", "network")) {
if (is.null(source.row.labels)) {
stop(paste0("The source at t = ", i, " does not contain any row labels."))
}
if (is.null(source.col.labels)) {
stop(paste0("The source at t = ", i, " does not contain any column labels."))
}
}
target.row.labels <- rownames(targets[[i]])
if (!targets.types[[i]] %in% c("matrix", "network")) {
target.col.labels <- rownames(targets[[i]])
}
else {
target.col.labels <- colnames(targets[[i]])
}
if (is.null(target.row.labels)) {
stop(paste0("The target at t = ", i, " does not contain any row labels."))
}
if (targets.types[[i]] %in% c("matrix", "network")) {
if (is.null(target.col.labels)) {
stop(paste0("The target at t = ", i, " does not contain any column labels."))
}
}
add.row.indices <- which(!target.row.labels %in%
source.row.labels)
add.row.labels <- target.row.labels[add.row.indices]
add.col.indices <- which(!target.col.labels %in%
source.col.labels)
add.col.labels <- target.col.labels[add.col.indices]
if (length(add.row.indices) > 0) {
for (j in 1:length(add.row.indices)) {
insert <- rep(value, ncol(sources[[i]]))
part1 <- sources[[i]][0:(add.row.indices[j] -
1), ]
if (class(part1) != "matrix") {
if (sources.types[[i]] %in% c("matrix", "network")) {
part1 <- matrix(part1, nrow = 1)
}
else {
part1 <- matrix(part1, ncol = 1)
}
}
rownames(part1) <- rownames(sources[[i]])[0:(add.row.indices[j] -
1)]
if (add.row.indices[j] <= nrow(sources[[i]])) {
part2 <- sources[[i]][add.row.indices[j]:nrow(sources[[i]]),
]
}
else {
part2 <- matrix(ncol = ncol(sources[[i]]),
nrow = 0)
}
if (class(part2) != "matrix") {
part2 <- matrix(part2, nrow = 1)
}
if (nrow(part2) > 0) {
rownames(part2) <- rownames(sources[[i]])[add.row.indices[j]:nrow(sources[[i]])]
sources[[i]] <- rbind(part1, insert, part2)
}
else {
sources[[i]] <- rbind(part1, insert)
}
rownames(sources[[i]])[add.row.indices[j]] <- add.row.labels[j]
if (sources.types[[i]] == "network" && sources.onemode[[i]] ==
TRUE) {
for (k in 1:length(sources.attributes[[i]])) {
at1 <- sources.attributes[[i]][[k]][0:(add.row.indices[j] -
1)]
at2 <- sources.attributes[[i]][[k]][add.row.indices[j]:length(sources.attributes[[i]][[k]])]
if (sources.attribnames[[i]][k] == "vertex.names") {
sources.attributes[[i]][[k]] <- c(at1,
add.row.labels[j], at2)
}
else if (sources.attribnames[[i]][k] ==
"na") {
sources.attributes[[i]][[k]] <- c(at1,
TRUE, at2)
}
else {
sources.attributes[[i]][[k]] <- c(at1,
value, at2)
}
}
}
}
}
if (length(add.col.indices) > 0 && sources.types[[i]] %in%
c("matrix", "network")) {
for (j in 1:length(add.col.indices)) {
insert <- rep(value, nrow(sources[[i]]))
part1 <- sources[[i]][, 0:(add.col.indices[j] -
1)]
if (class(part1) != "matrix") {
part1 <- matrix(part1, ncol = 1)
}
colnames(part1) <- colnames(sources[[i]])[0:(add.col.indices[j] -
1)]
if (add.col.indices[j] <= ncol(sources[[i]])) {
part2 <- sources[[i]][, add.col.indices[j]:ncol(sources[[i]])]
}
else {
part2 <- matrix(nrow = nrow(sources[[i]]),
ncol = 0)
}
if (class(part2) != "matrix") {
part2 <- matrix(part2, ncol = 1)
}
if (ncol(part2) > 0) {
colnames(part2) <- colnames(sources[[i]])[add.col.indices[j]:ncol(sources[[i]])]
sources[[i]] <- cbind(part1, insert, part2)
}
else {
sources[[i]] <- cbind(part1, insert)
}
colnames(sources[[i]])[add.col.indices[j]] <- add.col.labels[j]
}
}
if (sources.types[[i]] == "network" && sources.onemode[[i]] ==
FALSE) {
add.col.indices <- sapply(add.col.indices, function(x) x +
nr)
combined.indices <- c(add.row.indices, add.col.indices)
for (j in 1:length(sources.attributes[[i]])) {
if (length(combined.indices) > 0) {
for (k in 1:length(combined.indices)) {
at1 <- sources.attributes[[i]][[j]][0:(combined.indices[k] -
1)]
at2 <- sources.attributes[[i]][[j]][combined.indices[k]:length(sources.attributes[[i]][[j]])]
if (sources.attribnames[[i]][j] == "vertex.names") {
sources.attributes[[i]][[j]] <- c(at1,
add.col.labels[j], at2)
}
else if (sources.attribnames[[i]][j] ==
"na") {
sources.attributes[[i]][[j]] <- c(at1,
TRUE, at2)
}
else {
sources.attributes[[i]][[j]] <- c(at1,
value, at2)
}
}
}
}
}
}
removed.rows <- character()
removed.columns <- character()
if (remove == TRUE) {
nr <- nrow(sources[[i]])
source.row.labels <- rownames(sources[[i]])
if (!sources.types[[i]] %in% c("matrix", "network")) {
source.col.labels <- rownames(sources[[i]])
}
else {
source.col.labels <- colnames(sources[[i]])
}
if (sources.types[[i]] %in% c("matrix", "network")) {
if (nr == 0) {
stop(paste0("The source at t = ", i, " has no rows."))
}
if (is.null(source.row.labels)) {
stop(paste0("The source at t = ", i, " does not contain any row labels."))
}
if (is.null(source.col.labels)) {
stop(paste0("The source at t = ", i, " does not contain any column labels."))
}
}
target.row.labels <- rownames(targets[[i]])
if (!targets.types[[i]] %in% c("matrix", "network")) {
target.col.labels <- rownames(targets[[i]])
}
else {
target.col.labels <- colnames(targets[[i]])
}
if (targets.types[[i]] %in% c("matrix", "network")) {
if (is.null(target.row.labels)) {
stop(paste0("The target at t = ", i, " does not contain any row labels."))
}
if (is.null(target.col.labels)) {
stop(paste0("The target at t = ", i, " does not contain any column labels."))
}
}
source.row.labels <- rownames(sources[[i]])
source.col.labels <- colnames(sources[[i]])
target.row.labels <- rownames(targets[[i]])
target.col.labels <- colnames(targets[[i]])
keep.row.indices <- which(source.row.labels %in%
target.row.labels)
if (sources.types[[i]] %in% c("matrix", "network") &&
targets.types[[i]] %in% c("matrix", "network")) {
keep.col.indices <- which(source.col.labels %in%
target.col.labels)
}
else if (sources.types[[i]] %in% c("matrix", "network") &&
!targets.types[[i]] %in% c("matrix", "network")) {
if (sources.onemode[[i]] == TRUE) {
keep.col.indices <- keep.row.indices
}
else {
keep.col.indices <- 1:ncol(sources[[i]])
}
}
else {
keep.col.indices <- 1
}
removed.rows <- which(!1:nrow(as.matrix(sources[[i]])) %in%
keep.row.indices)
removed.columns <- which(!1:ncol(as.matrix(sources[[i]])) %in%
keep.col.indices)
sources[[i]] <- as.matrix(sources[[i]][keep.row.indices,
keep.col.indices])
if (sources.types[[i]] == "network") {
if (sources.onemode[[i]] == TRUE) {
for (j in 1:length(sources.attributes[[i]])) {
sources.attributes[[i]][[j]] <- sources.attributes[[i]][[j]][keep.row.indices]
}
}
else {
keep.col.indices <- sapply(keep.col.indices,
function(x) x + nr)
combined.indices <- c(keep.row.indices, keep.col.indices)
for (j in 1:length(sources.attributes[[i]])) {
sources.attributes[[i]][[j]] <- sources.attributes[[i]][[j]][combined.indices]
}
}
}
}
if (sources.types[[i]] %in% c("matrix", "network") &&
targets.types[[i]] %in% c("matrix", "network") &&
nrow(sources[[i]]) == nrow(targets[[i]]) && ncol(sources[[i]]) ==
ncol(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
colnames(targets[[i]])]
}
else if (sources.types[[i]] %in% c("matrix", "network") &&
!targets.types[[i]] %in% c("matrix", "network") &&
nrow(sources[[i]]) == nrow(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
rownames(targets[[i]])]
}
else if (length(sources[[i]]) == nrow(targets[[i]])) {
sources[[i]] <- sources[[i]][rownames(targets[[i]]),
]
}
else if (add == FALSE && (nrow(sources[[i]]) < nrow(targets[[i]]) ||
any(rownames(sources[[i]]) != rownames(targets[[i]])))) {
}
if (sources.types[[i]] == "network") {
sources[[i]] <- network(sources[[i]], directed = sources.directed[[i]],
bipartite = !sources.onemode[[i]])
for (j in 1:length(sources.attribnames[[i]])) {
sources[[i]] <- set.vertex.attribute(sources[[i]],
sources.attribnames[[i]][j], sources.attributes[[i]][[j]])
}
}
if (!sources.types[[i]] %in% c("matrix", "network") &&
class(sources[[i]]) == "matrix" && ncol(sources[[i]]) ==
1) {
sources[[i]] <- sources[[i]][, 1]
}
if (returnlabels == TRUE) {
sources[[i]] <- list()
sources[[i]]$removed.row <- removed.rows
sources[[i]]$removed.col <- removed.columns
sources[[i]]$added.row <- add.row.labels
sources[[i]]$added.col <- add.col.labels
}
}
for (i in 1:length(sources)) {
if (sources.types[[i]] == "network" && !is.null(sources.matrixnames[[i]]) &&
length(sources.matrixnames[[i]]) > 0) {
for (j in 1:length(sources.matrixnames[[i]])) {
mat <- adjust(source = sources.matrices[[i]][[j]],
target = sources[[i]], add = add, remove = remove,
value = value)
set.network.attribute(sources[[i]], sources.matrixnames[[i]][j],
mat)
}
}
}
if (sources.initialtype == "list") {
return(sources)
}
else {
return(sources[[1]])
}
}
<bytecode: 0xb3f4278>
<environment: namespace:xergm.common>
--- function search by body ---
Function adjust in namespace xergm.common has this body.
----------- END OF FAILURE REPORT --------------
Error in if (class(source) == "matrix") { : the condition has length > 1
Calls: adjust
Execution halted
Flavor: r-devel-linux-x86_64-fedora-gcc