#' @exportClass Node
#' @name Node
#' @rdname Node
#' @aliases Node-class
#' @title The Node class
#'
#' @description
#' This class is part of the \pkg{HNUORTools}. It represents
#' the base class for every locateable class in an
#' \dfn{Operations-Research (OR)}-context.
#'
#' @details Find here the defined slots for this class.
#' @section Slots:
#' \describe{
#' \item{\code{id}:}{
#' Object of class \code{"character"}, containing data from id.
#' \strong{Should be unique}.
#' The default value will be caluclated randomly.
#' }
#' \item{\code{label}:}{
#' Object of class \code{"character"}, containing the label of
#' the \code{\link{Node}}.
#' The default value will be caluclated randomly.
#' }
#' \item{\code{x}:}{
#' Object of class \code{"numeric"}, containing the x-coordinate
#' of the \code{\link{Node}}.
#' The default value will be caluclated randomly.
#' }
#' \item{\code{y}:}{
#' Object of class \code{"numeric"}, containing the y-coordinate
#' of the \code{\link{Node}}.
#' The default value will be caluclated randomly.
#' }
#' }
#'
#' @seealso The classes are derived from this class and the following Methods can be used with this class.:
#' @section Creating objects of type \code{\link{Node}}:
#' \describe{
#' \item{Creating an \code{S4-Object}}{
#' \code{new("Node", ...)}
#' }
#' \item{Converting from a \code{data.frame}}{
#' \code{as.Node{<data.frame>}}
#' See also below in the Methods-Section.
#' }
#' \item{Converting from a \code{list}}{
#' \code{as.Node{<list>}}
#' See also below in the Methods-Section.
#' }
#' }
#' @section Methods:
#' \describe{
#' \item{\code{as.list(node, ...)}}{
#' Converts a \code{\link{Node}} into a \code{\link{list}}.
#' \code{...} are user-defined (not used) parameters.
#' }
#' \item{\code{as.data.frame(node, ...)}}{
#' Converts a \code{\link{Node}} into a \code{\link{data.frame}}.
#' \code{as.data.frame} accepts the optional parameter \code{withrownames} of class \code{"logical"} (default is \code{TRUE}).
#' If \code{withrownames == TRUE} the returned \code{\link{data.frame}} will recieve the \code{id} as rowname.
#' \code{...} are user-defined (not used) parameters.
#'
#' }
#' \item{\code{as.Node(obj)}}{
#' Converts an object of class \code{\link{data.frame}} or of class \code{\link{list}} into a \code{\link{Node}}.
#' }
#' \item{\code{is.Node(obj)}}{
#' Checks if the object \code{obj} is of type \code{\link{Node}}.
#' }
#' \item{\code{\link{getDistance}}}{
#' Calculating the distance between two \code{\link{Node}s}
#' (As the classes \code{\link{Customer}} and \code{\link{Warehouse}}
#' depend on \code{\link{Node}}, distances can be calculated between any of these objects).
#' }
#' \item{\code{\link{getpolar}}}{
#' Calculating the polar-angle to the x-Axis of a link,
#' connecting two \code{\link{Node}s}
#' (As the classes \code{\link{Customer}} and \code{\link{Warehouse}}
#' depend on \code{\link{Node}}, polar-angles can be calculated between any of these objects).
#' }
#' }
#'
#' @section Derived Classes:
#' \describe{
#' \item{\code{\link{Customer}}}{
#' This class extends the \code{\link{Node}}-Class
#' with attributes for according to customers for OR-Problems.
#' }
#' \item{\code{\link{Warehouse}}}{
#' This class extends the \code{\link{Node}}-Class
#' with attributes for according to warehouses for OR-Problems.
#' }
#' \item{\code{\link{Link}}}{
#' This class is constructed by two entities of the \code{\link{Node}}-Class
#' representing the origin and destination of \code{\link{Link}} for OR-Problems.
#' }
#' }
#' @section To be used for:
#' \describe{
#' \item{SPP}{
#' Shortest-Path-Problem
#' }
#' \item{TSP}{
#' Travelling Salesman Problem
#' }
#' }
#'
#' @note
#' for citing use: Felix Lindemann (2014). HNUORTools: Operations Research Tools. R package version 1.1-0. \url{http://felixlindemann.github.io/HNUORTools/}.
#'
#' @author Dipl. Kfm. Felix Lindemann \email{felix.lindemann@@hs-neu-ulm.de}
#'
#' Wissenschaftlicher Mitarbeiter
#' Kompetenzzentrum Logistik
#' Buro ZWEI, 17
#'
#' Hochschule fur angewandte Wissenschaften
#' Fachhochschule Neu-Ulm | Neu-Ulm University
#' Wileystr. 1
#'
#' D-89231 Neu-Ulm
#'
#'
#' Phone +49(0)731-9762-1437
#' Web \url{www.hs-neu-ulm.de/felix-lindemann/}
#' \url{http://felixlindemann.blogspot.de}
#' @examples
#' # create a new Node with specific values
#' x<- new("Node", x= 10, y=20, id="myid", label = "mylabel")
#' x
#' # create from data.frame
#' df<- data.frame(x=10,y=20)
#' new("Node", df)
#' as(df, "Node")
#' as.Node(df)
#' #create some nodes
#' n1 <- new("Node",x=10,y=20, id ="n1")
#' n2 <- new("Node",x=13,y=24, id ="n1")
#' # calculate Beeline distance
#' #getDistance(n1,n2) # should result 5
#' #getDistance(n1,n2, costs = 2) # should result 10
setClass(
Class = "Node",
representation=representation(
id = "character",
label = "character",
x = "numeric",
y = "numeric"
),
validity = function(object){
N <- length(object@id)
if(length(object@label) != N)
return("Invalid Object of Type 'Node': the length of the attributes 'id' and 'label' differ!")
if(length(object@x) != N)
return("Invalid Object of Type 'Node': the length of the attributes 'id' and 'x' differ!")
if(length(object@y) != N)
return("Invalid Object of Type 'Node': the length of the attributes 'id' and 'y' differ!")
if( sum(is.null(object@x)) + sum( is.na(object@x)) > 0 )
return(paste("Invalid Object of Type 'Node': Error with value x: Value is not initialized", class(object@x)))
if( sum(is.null(object@y)) + sum( is.na(object@y)) > 0)
return(paste("Invalid Object of Type 'Node': Error with value y: Value is not initialized", class(object@y)))
if( class(object@x)!="numeric" )
return(paste("Invalid Object of Type 'Node': Error with value x: expected numeric datatype, but obtained", class(object@x)))
if( class(object@y)!="numeric" )
return(paste("Invalid Object of Type 'Node': Error with value y: expected numeric datatype, but obtained", class(object@y)))
return(TRUE)
}
)
################################### initialize - Method ###################################################
#' @title initialize Method
#' @name initialize
#' @aliases initialize,Node-method
#' @rdname initialize-methods
#' @param data can of type \code{\link{data.frame}} or \code{\link{list}}
setMethod("initialize", signature="Node", function(.Object, data=NULL, ...) {
li <- list(...)
N<-1
if(is.null(li$showwarnings)) li$showwarnings <- FALSE
if(!is.null(data)){
if(class(data) =="list") {
data <- as.data.frame(data)
}
if(class(data) =="data.frame") {
N<-nrow(data)
li$id <- data$id
li$label <- data$label
li$x <- data$x
li$y <- data$y
} else{
stop("Error: argument data should be of type 'data.frame'!")
}
}
if(is.null(li$x)) {
li$x <- as.numeric(runif(N,0,100))
w <- paste("x-Coordinate simulated (x= ",li$x,").")
if(li$showwarnings) warning(w)
}
if(is.null(li$y)) {
li$y <- as.numeric(runif(N,0,100))
w <- paste("y-Coordinate simulated (y= ",li$y,").")
if(li$showwarnings) warning(w)
}
if(is.null(li$id)) {
tmp.id <-NULL
for(i in 1:N){
tmp.id <- c(tmp.id, UUIDgenerate())
}
li$id <- tmp.id
w <- paste("Random ID (",li$id,") provided. Uniqueness should be given.")
if(li$showwarnings) warning(w)
}
if(is.null(li$label)) {
li$label <- li$id
}
.Object@id <- as.character(li$id)
.Object@label <- as.character(li$label)
.Object@x <- as.numeric( li$x)
.Object@y <- as.numeric( li$y)
validObject(.Object)
return(.Object )
})
################################### extract - Method ###################################################
#' @title Extract Methods
#' @name $
#' @aliases $,Node-method
#' @rdname Extract-methods-1
#' @param name Name of Attribute.
setMethod("$","Node",function(x,name) {return(slot(x,name))})
#' @title Extract Methods
#' @name [
#' @aliases [,Node-method
#' @rdname Extract-methods-2
#' @param i Row Index
#' @param j Name or Column index
#' @param drop Optional value for Drop-Levels.
setMethod("[", "Node",
function(x, i, j, drop){
N <- length(x)
if(min(i) <=0) stop("Index i out of bound. it must be positive non zero.")
if(max(i) >N) stop("Index i out of bound. it must not be larger than the total length.")
if(!missing(j)){
if(class(j) == "character"){
return(slot(x,j)[i])
}
if(class(j) == "integer"){
return(slot(x,j)[i])
}
}
df <- as.data.frame(x)[i,]
return (new("Node", df))
}
)
################################### Set - Method ###################################################
#' @title Set Methods
#' @name $<-
#' @aliases $<-,Node-method
#' @rdname Set-methods-1
#' @param name Name of parameter to change
#' @param value new Value.
setMethod("$<-","Node",function(x,name,value) {
slot(x,name,check=TRUE) <- value
valid<-validObject(x)
return(x)
})
#' @title Set Methods
#' @name [<-
#' @aliases [<-,Node-method
#' @rdname Set-methods-2
#' @param x The Node
#' @param i row-Index
#' @param j Name or Column index
setReplaceMethod("[",signature(x="Node"),
function(x,i,j,value){
N <- length(x)
if(min(i) <=0) stop("Index i out of bound. It must be positive non zero.")
if(max(i) >N) stop("Index i out of bound. It must not be larger than the total length.")
if(length(value)!=length(i)) stop("The replacement length is not equal to the number of elements to be replaced.")
if(is(value, "Node")){
# copy original values to tmp vectors
tmp <- as.data.frame(x)
#replace the item(s) regarding to i
tmp$id[i] <- value@id
tmp$label[i] <- value@label
tmp$x[i] <- value@x
tmp$y[i] <- value@y
# return new item
return (new("Node", tmp))
} else {
if(missing(j)) {
# call the function recursivly
# might throw an error if the conversion is not supported.
x[i] <- as.Node(value)
}else{
if(class(j) == "character"){
slot(x,j)[i] <- value
}else if(class(j) == "integer" | class(j) == "numeric"){
slot(x,slotNames(x)[j])[i] <- value
}else{
warning(paste("no changes have been made. the provided value of j (class:",class(j), "value:",j,") was not recocnized."))
}
}
valid<-validObject(x)
return(x)
}
}
)
################################### as... - Method ###################################################
#local Methods
as.Node.list = function(x, ...){return(new("Node", data=x))}
as.Node.data.frame = function(x, ...){return(new("Node", data=x))}
#local convert message
as.data.frame.Node = function(x, ...){
li<-list(...)
if(is.null(li$withrownames)) li$withrownames <- FALSE
df<-data.frame(id=x@id, label = x@label, x= x@x, y= x@y)
if(li$withrownames) rownames(df)<-x@id
return (df)
}
as.list.Node = function(x, ...){list(id=x@id, label = x@label, x= x@x, y= x@y)}
#' @export
setGeneric("as.Node", function(x, ...) standardGeneric( "as.Node"))
#' @title Convert Objects to Nodes
#' @name as.Node
#' @param x an Object to convert.
#' @param ... optional parameters
#' @aliases as.Node,list-method
#' @rdname as.Node-methods
setMethod("as.Node", signature(x = "list"), as.Node.list)
#' @title Convert Objects to Nodes
#' @name as.Node
#' @aliases as.Node,data.frame-method
#' @rdname as.Node-methods
setMethod("as.Node", signature(x = "data.frame"), as.Node.data.frame)
#' @title Convert Objects to lists
#' @name as.list
#' @param x the Node
#' @aliases as.list,Node-method
#' @rdname as.list-methods
setMethod("as.list", signature(x = "Node"), as.list.Node)
#' @title Convert Objects to data.frames
#' @name as.data.frame
#' @param x the Node
#' @aliases as.data.frame,Node-method
#' @rdname as.data.frame-methods
setMethod("as.data.frame", signature(x = "Node"), as.data.frame.Node)
setAs("data.frame", "Node", def=function(from){return(as.Node.data.frame(from))})
setAs("list", "Node", def=function(from){return(as.Node.list(from))})
################################### is... - Method ###################################################
#' @title Checks if an Object is as Node
#' @export
#' @name is.Node
#' @param x the Node
#' @param ... optional Parameters (not supported)
setGeneric("is.Node", function(x, ...) standardGeneric( "is.Node"))
#' @aliases is.Node,Node-method
#' @rdname is.Node
setMethod( "is.Node", "Node", function(x, ...){
return(is(x ,"Node"))
})
#' @title How many Nodes are included?
#' @name length
#' @param x the Nodes
#' @aliases length,Node-method
#' @rdname length
setMethod("length", "Node",
function(x){
N <- length(x@id)
return(N)
}
)
#' @aliases getDistance,Node,Node-method
#' @rdname getDistance
#' @examples
#' # w1 <- new("Node", x=0, y=0)
#' # c1 <- new("Node", x=3, y=4)
#' # getDistance(w1,c1) # should result 5.
#' # getDistance(w1,c1,costfactor=3) # should result 15.
setMethod( "getDistance", signature = c("Node", "Node"),
function(n0,n1, ...) {
li<-list(...)
p0<-c(n0$x,n0$y)
p1<-c(n1$x,n1$y)
value <- getDistance(p0,p1, ...)
return(value)
}
)
#' @aliases getpolar,Node,Node-method
#' @rdname getpolar
#' @examples
#' # w1 <- new("Node", x=0, y=0)
#' # c1 <- new("Node", x=1, y=1)
#' # getpolar(w1,c1,deg=TRUE) # should result 45.
setMethod("getpolar", signature=c("Node", "Node"),
function(n0,n1, ...) {
li<-list(...)
validObject(n0)
validObject(n1)
p0<-c(n0$x,n0$y)
p1<-c(n1$x,n1$y)
value <- getpolar(p0,p1, ...)
return(value)
}
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.