######################
### global methods ###
######################
setMethod(f="as.matrix", signature="simpleTriplet",
definition=function(x, ...) {
M <- matrix(0, nrow=g_nr_rows(x), ncol=g_nr_cols(x))
i.x <- g_row_ind(x)
j.x <- g_col_ind(x)
v.x <- g_values(x)
for ( i in 1:g_nr_cells(x) ) {
M[i.x[i], j.x[i]] <- v.x[i]
}
return(M)
}
)
##############################################
### methods only for class 'simpleTriplet' ###
##############################################
#' @aliases get.simpleTriplet,simpleTriplet,character,list-method
#' @rdname get.simpleTriplet-method
setMethod(f="get.simpleTriplet", signature=c("simpleTriplet", "character", 'list'),
definition=function(object, type, input) {
if ( !type %in% c("rowInd", "colInd", "values", "nrRows",
"nrCols", "nrCells", "duplicatedRows", "transpose",
"getRow", "getCol") ) {
stop("get.simpleTriplet:: argument 'type' is not valid!\n")
}
if ( type == "rowInd" ) {
return(g_row_ind(object))
}
if ( type == "colInd" ) {
return(g_col_ind(object))
}
if ( type == "values" ) {
return(g_values(object))
}
if ( type == "nrRows" ) {
return(g_nr_rows(object))
}
if ( type == "nrCols" ) {
return(g_nr_cols(object))
}
if ( type == "nrCells" ) {
return(g_nr_cells(object))
}
if ( type == "duplicatedRows" ) {
return(g_duplicated_rows(object))
}
if ( type == "transpose" ) {
return(g_transpose(object))
}
if ( type == "getRow" ) {
return(g_row(object, input))
}
if ( type == "getCol" ) {
return(g_col(object, input))
}
}
)
#' @aliases calc.simpleTriplet,simpleTriplet,character,list-method
#' @rdname calc.simpleTriplet-method
setMethod(f="calc.simpleTriplet", signature=c("simpleTriplet", "character", "list"),
definition=function(object, type, input) {
if ( !type %in% c("removeRow", "removeCol", "addRow", "addCol",
"modifyRow", "modifyCol", "modifyCell", "bind") ) {
stop("calc.simpleTriplet:: check argument 'type'!\n")
}
if ( type == "removeRow" ) {
return(c_remove_row(object, input))
}
if ( type == "removeCol" ) {
return(c_remove_col(object, input))
}
if ( type == "addRow" ) {
return(c_add_row(object, input))
}
if ( type == "addCol" ) {
return(c_add_col(object, input))
}
if ( type == "modifyRow" ) {
return(c_modify_row(object, input))
}
if ( type == 'modifyCol' ) {
return(c_modify_col(object, input))
}
if ( type == "modifyCell" ) {
return(c_modify_cell(object, input))
}
if ( type == "bind" ) {
return(c_bind(object, input))
}
}
)
#' @aliases init.simpleTriplet,character,list-method
#' @rdname init.simpleTriplet-method
setMethod(f='init.simpleTriplet', signature=c('character', 'list'),
definition=function(type, input) {
if ( !type %in% c('simpleTriplet', 'simpleTripletDiag') ) {
stop("init.simpleTriplet:: check argument 'type'!\n")
}
if ( type == 'simpleTriplet' ) {
matA <- input$mat
dims <- dim(matA)
v <- as.vector(t(matA))
ind <- v!=0
i <- rep(1:dims[1], each=dims[2])[ind==TRUE]
j <- rep(1:dims[2], length=dims[1]*dims[2])[ind]
v <- v[ind]
out <- new("simpleTriplet",
i=i,
j=j,
v=v,
nrRows=dims[1],
nrCols=dims[2]
)
}
if ( type == 'simpleTripletDiag' ) {
nrRows <- input$nrRows
negative <- input$negative
i <- j <- 1:nrRows
if ( negative ) {
v <- rep(-1, nrRows)
} else {
v <- rep(1, nrRows)
}
out <- new("simpleTriplet",
i=i,
j=j,
v=v,
nrRows=nrRows,
nrCols=nrRows
)
}
validObject(out)
return(out)
}
)
# get-methods
setMethod("g_row_ind", signature=c("simpleTriplet"), definition=function(object) {
return(object@i)
})
setMethod("g_col_ind", signature=c("simpleTriplet"), definition=function(object) {
return(object@j)
})
setMethod("g_values", signature=c("simpleTriplet"), definition=function(object) {
return(object@v)
})
setMethod("g_nr_rows", signature=c("simpleTriplet"), definition=function(object) {
return(object@nrRows)
})
setMethod("g_nr_cols", signature=c("simpleTriplet"), definition=function(object) {
return(object@nrCols)
})
setMethod("g_nr_cells", signature=c("simpleTriplet"), definition=function(object) {
return(length(g_values(object)))
})
setMethod("g_duplicated_rows", signature=c("simpleTriplet"), definition=function(object) {
i <- g_row_ind(object)
j <- g_col_ind(object)
v <- g_values(object)
len <- g_nr_rows(object)
o <- order(i, j)
y <- split(paste(j[o], v[o], sep = "\r"), i[o])
tmp <- character(len)
names(tmp) <- seq_along(tmp)
tmp[names(y)] <- sapply(y, paste, collapse = "\r")
dupRows <- which(duplicated(tmp))
if ( length(dupRows) == 0 ) {
dupRows <- NULL
}
return(dupRows)
})
setMethod("g_transpose", signature=c("simpleTriplet"), definition=function(object) {
out <- init.simpleTriplet(type='simpleTriplet', input=list(mat=matrix(0, nrow=g_nr_cols(object), ncol=0)))
for ( i in 1:g_nr_rows(object) ) {
r <- g_row(object, input=list(i))
out <- c_add_col(out, input=list(index=g_col_ind(r), values=g_values(r)))
}
return(out)
})
setMethod("g_row", signature=c("simpleTriplet", "list"), definition=function(object, input) {
# if somebody specifies a vector of length > 1, the row with the first index is returned
index <- input[[1]][1]
if ( !index %in% 1:g_nr_rows(object) ) {
stop("g_row:: parameter 'index' must be >=1 and <=",g_nr_rows(object),"!\n")
}
out <- NULL
indI <- which(g_row_ind(object) == index)
if ( length(indI) > 0 ) {
out <- new("simpleTriplet",
i=rep(1, length(indI)),
j=g_col_ind(object)[indI],
v=g_values(object)[indI],
nrRows=1,
nrCols=g_nr_cols(object)
)
}
return(out)
})
setMethod("g_col", signature=c("simpleTriplet", "list"), definition=function(object, input) {
# if somebody specifies a vector of length > 1, the column with the first index is returned
index <- input[[1]][1]
if ( !index %in% 1:g_nr_cols(object) ) {
stop("g_col:: parameter 'index' must be >=1 and <=",g_nr_cols(object),"!\n")
}
out <- NULL
indJ <- which(g_col_ind(object) == index)
if ( length(indJ) > 0 ) {
out <- new("simpleTriplet",
i=g_row_ind(object)[indJ],
j=rep(1, length(indJ)),
v=g_values(object)[indJ],
nrRows=g_nr_rows(object),
nrCols=1
)
}
return(out)
})
setMethod("c_remove_row", signature=c("simpleTriplet"), definition=function(object, input) {
index <- input[[1]]
if ( !all(index %in% 1:g_nr_rows(object)) ) {
stop("c_remove_row:: check dimensions of parameter 'index'!\n")
}
ind <- which(g_row_ind(object) %in% index)
if ( length(ind) > 0 ) {
object@i <- g_row_ind(object)[-ind]
object@j <- g_col_ind(object)[-ind]
object@v <- g_values(object)[-ind]
}
object@nrRows <- g_nr_rows(object)-length(index)
object@i <- rep(1:length(unique(g_row_ind(object))), table(g_row_ind(object)))
validObject(object)
return(object)
})
setMethod("c_remove_col", signature=c("simpleTriplet"), definition=function(object, input) {
index <- input[[1]]
if ( !all(index %in% 1:g_nr_cols(object)) ) {
stop("c_remove_col:: check dimensions of parameter 'index'!\n")
}
ind <- which(g_col_ind(object) %in% index)
if ( length(ind) > 0 ) {
object@i <- g_row_ind(object)[-ind]
object@j <- g_col_ind(object)[-ind]
object@v <- g_values(object)[-ind]
}
object@nrCols <- g_nr_cols(object)-length(index)
object@j <- rep(1:length(unique(g_col_ind(object))), table(g_col_ind(object)))
validObject(object)
return(object)
})
setMethod("c_add_row", signature=c("simpleTriplet"), definition=function(object, input) {
index <- input[[1]]
values <- input[[2]]
if ( !all(index %in% 1:g_nr_cols(object)) ) {
stop("c_add_row:: check dimensions of parameter 'index'!\n")
}
if ( length(index) != length(values) ) {
stop("c_add_row:: dimensions of 'index' and 'values' do not match!\n")
}
rowInd <- g_nr_rows(object)+1
object@nrRows <- rowInd
ind <- which(values != 0)
nrAddedCells <- length(ind)
if ( nrAddedCells > 0 ) {
object@i <- c(g_row_ind(object), rep(rowInd, nrAddedCells))
object@j <- c(g_col_ind(object), index[ind])
object@v <- c(g_values(object), values[ind])
}
validObject(object)
return(object)
})
setMethod("c_add_col", signature=c("simpleTriplet"), definition=function(object, input) {
index <- input[[1]]
values <- input[[2]]
if ( !all(index %in% 1:g_nr_rows(object)) ) {
stop("c_add_col:: check dimensions of parameter 'index'!\n")
}
if ( length(index) != length(values) ) {
stop("c_add_col:: dimensions of 'index' and 'values' do not match!\n")
}
colInd <- g_nr_cols(object)+1
object@nrCols <- colInd
ind <- which(values != 0)
nrAddedCells <- length(ind)
if ( nrAddedCells > 0 ) {
object@i <- c(g_row_ind(object), index[ind])
object@j <- c(g_col_ind(object), rep(colInd, nrAddedCells))
object@v <- c(g_values(object), values[ind])
}
validObject(object)
return(object)
})
setMethod("c_modify_row", signature=c("simpleTriplet"), definition=function(object, input) {
rowInd <- input[[1]]
colInd <- input[[2]]
values <- input[[3]]
if ( length(rowInd) != 1 ) {
stop("c_modify_row:: length of parameter 'rowInd' must equal 1!\n")
}
if ( !rowInd %in% 1:g_nr_rows(object) ) {
stop("c_modify_row:: check dimensions of parameter 'rowInd'!\n")
}
if ( !all(colInd %in% 1:g_nr_cols(object)) ) {
stop("c_modify_row:: check dimensions of parameter 'colInd'!\n")
}
if ( length(colInd) != length(values) ) {
stop("c_modify_row:: dimensions of 'colInd' and 'values' do not match!\n")
}
ind <- which(g_row_ind(object) %in% rowInd)
if ( length(ind) == 0 ) {
stop("c_modify_row:: no row to modify!\n")
}
for ( j in seq_along(colInd) ) {
object <- c_modify_cell(object, input=list(rowInd, colInd[j], values[j]))
}
validObject(object)
return(object)
})
setMethod("c_modify_col", signature=c("simpleTriplet"), definition=function(object, input) {
rowInd <- input[[1]]
colInd <- input[[2]]
values <- input[[3]]
if ( length(colInd) != 1 ) {
stop("c_modify_col:: length of parameter 'colInd' must equal 1!\n")
}
if ( !all(rowInd %in% 1:g_nr_rows(object)) ) {
stop("c_modify_col:: check dimensions of parameter 'rowInd'!\n")
}
if ( !colInd %in% 1:g_nr_cols(object) ) {
stop("c_modify_col:: check dimensions of parameter 'colInd'!\n")
}
if ( length(rowInd) != length(values) ) {
stop("c_modify_col:: dimensions of 'rowInd' and 'values' do not match!\n")
}
ind <- which(g_col_ind(object) %in% colInd)
if ( length(ind) == 0 ) {
stop("c_modify_col:: no column to modify!\n")
}
for ( i in seq_along(rowInd) ) {
object <- c_modify_cell(object, input=list(rowInd[i], colInd, values[i]))
}
validObject(object)
return(object)
})
setMethod("c_modify_cell", signature=c("simpleTriplet"), definition=function(object, input) {
rowInd <- input[[1]]
colInd <- input[[2]]
values <- input[[3]]
if ( any(length(values), length(rowInd), length(colInd) != 1) ) {
stop("c_modify_cell:: length of all arguments 'rowInd', 'colInd', 'values' must equal 1!\n")
}
if ( !all(colInd %in% 1:g_nr_cols(object)) ) {
stop("c_modify_cell:: check dimensions of parameter 'colInd'!\n")
}
if ( !all(rowInd %in% 1:g_nr_rows(object)) ) {
stop("c_modify_cell:: check dimensions of parameter 'rowInd'!\n")
}
ind <- which(g_row_ind(object) == rowInd & g_col_ind(object) == colInd)
if ( length(ind) == 1 & values != 0 ) {
object@v[ind] <- values
} else if ( length(ind)==1 & values == 0 ) {
object@i <- g_row_ind(object)[-ind]
object@j <- g_col_ind(object)[-ind]
object@v <- g_values(object)[-ind]
} else if ( length(ind)==0 & values!=0 ) {
object@i <- c(g_row_ind(object), rowInd)
object@j <- c(g_col_ind(object), colInd)
object@v <- c(g_values(object), values)
}
validObject(object)
return(object)
})
setMethod("c_bind", signature=c("simpleTriplet"), definition=function(object, input) {
object1 <- object
object2 <- input[[1]]
bindRow <- input[[2]]
if ( bindRow == TRUE ) {
# "rbind"
if ( g_nr_cols(object1) != g_nr_cols(object2) ) {
stop("c_bind:: nr of columns of 'object1' and 'object2' differ!\n")
}
out <- init.simpleTriplet(type='simpleTriplet',
input=list(mat=matrix(0, nrow=g_nr_rows(object1) + g_nr_rows(object2), ncol=g_nr_cols(object1))))
object2@i <- object2@i + g_nr_rows(object1)
} else {
# "cbind"
if ( g_nr_rows(object1) != g_nr_rows(object2) ) {
stop("c_bind:: nr of rows of 'object1' and 'object2' differ!\n")
}
out <- init.simpleTriplet(type='simpleTriplet',
input=list(mat=matrix(0, nrow=g_nr_rows(object1), ncol=g_nr_cols(object1)+g_nr_cols(object2))))
object2@j <- object2@j + g_nr_cols(object1)
}
out@i <- c(object1@i, object2@i)
out@j <- c(object1@j, object2@j)
out@v <- c(object1@v, object2@v)
validObject(out)
return(out)
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.