#' @exportClass Customer
#' @name Customer
#' @rdname Customer
#' @aliases Customer-class
#' @title The Customer 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{demand}:}{
#' Object of class \code{"numeric"}, containing the amount for the demand.
#' The default value cannot be negative.
#' }
#' \item{\code{isDummy}:}{
#' Object of class \code{"logical"}, indicating if a customer was added
#' in an algorithm (e.g. TPP-Column-Minimum-Method) in order to avoid
#' degenerated soulutions.
#' }
#' }
#' @section Slots (from \code{\link{Node}}):
#' \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{Customer}}.
#' The default value will be caluclated randomly.
#' }
#' \item{\code{x}:}{
#' Object of class \code{"numeric"}, containing the x-coordinate
#' of the \code{\link{Customer}}.
#' The default value will be caluclated randomly.
#' }
#' \item{\code{y}:}{
#' Object of class \code{"numeric"}, containing the y-coordinate
#' of the \code{\link{Customer}}.
#' 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{Customer}}:
#' \describe{
#' \item{Creating an \code{S4-Object}}{
#' \code{new("Customer", ...)}
#' }
#' \item{Converting from a \code{data.frame}}{
#' \code{as.Customer{<data.frame>}}
#' See also below in the Methods-Section.
#' }
#' \item{Converting from a \code{list}}{
#' \code{as.Customer{<list>}}
#' See also below in the Methods-Section.
#' }
#' }
#' @section Methods:
#' \describe{
#' \item{\code{as.list(Customer, ...)}}{
#' Converts a \code{\link{Customer}} into a \code{\link{list}}.
#' \code{...} are user-defined (not used) parameters.
#' }
#' \item{\code{as.data.frame(Customer, ...)}}{
#' Converts a \code{\link{Customer}} 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.Customer(obj)}}{
#' Converts an object of class \code{\link{data.frame}} or of class \code{\link{list}} into a \code{\link{Customer}}.
#' }
#' \item{\code{is.Customer(obj)}}{
#' Checks if the object \code{obj} is of type \code{\link{Customer}}.
#' }
#' \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:
#' None.
#' @section To be used for:
#' \describe{
#' \item{WLP}{
#' Warehouse-Location-Problem
#' }
#' \item{TPP}{
#' Transportation Problem
#' }
#' \item{VRP}{
#' Vehicle Routing 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 Customer with specific values
#' x<- new("Customer", x= 10, y=20, id="myid", label = "mylabel", demand = 20)
#' x
#' # create from data.frame
#' df<- data.frame(x=10,y=20, demand = 30)
#' new("Customer", df)
#' as(df, "Customer")
#' as.Customer(df)
#' #create some Customers
#' n1 <- new("Customer",x=10,y=20, demand = 30, id ="n1")
#' n2 <- new("Customer",x=13,y=24, demand = 40, id ="n2")
#' # calculate Beeline distance
#' #getDistance(n1,n2) # should result 5
#' #getDistance(n1,n2, costs = 2) # should result 10
setClass(
Class = "Customer",
representation=representation(
demand="numeric",
isDummy = "logical"
),
contains = "Node",
validity = function(object){
df <- as.data.frame(object)
node <- as.Node(df)
if(validObject(node)){
N <- length(object@id)
if(length(object@demand) != N)
return("Invalid Object of Type 'Customer': the length of the attributes 'id' and 'demand' differ!")
if(length(object@isDummy) != N)
return("Invalid Object of Type 'Customer': the length of the attributes 'id' and 'isDummy' differ!")
if( sum(is.null(object@demand)) + sum( is.na(object@demand)) > 0 )
return(paste("Invalid Object of Type 'Customer': Error with value demand: Value is not initialized", class(object@demand)))
if( sum(is.null(object@isDummy)) + sum( is.na(object@isDummy)) > 0)
return(paste("Invalid Object of Type 'Customer': Error with value isDummy: Value is not initialized", class(object@isDummy)))
if( class(object@demand)!="numeric" )
return(paste("Invalid Object of Type 'Customer': Error with value demand: expected numeric datatype, but obtained", class(object@demand)))
if( class(object@isDummy)!="logical" )
return(paste("Invalid Object of Type 'Customer': Error with value isDummy: expected logical datatype, but obtained", class(object@isDummy)))
if(min(object@demand)<0)
return(paste("Invalid Object of Type 'Customer': Error with value demand: at least one value is negative. Only positive Values are allowed."))
return(TRUE)
}else{
return (FALSE)
}
}
)
################################### initialize - Method ###################################################
#' @title initialize Method
#' @name initialize
#' @aliases initialize,Customer-method
#' @rdname initialize-methods
setMethod("initialize", signature="Customer", function(.Object, data=NULL, ...) {
li <- list(...)
if(is.null(li$showwarnings)) li$showwarnings <- FALSE
#init from parent Node-Object.
N<-1
if(!is.null(data)){
if(class(data) =="list") {
data <- as.data.frame(data)
}
if(class(data) =="data.frame") {
N<-nrow(data)
li$isDummy <- data$isDummy
li$demand <- data$demand
} else{
stop("Error: argument data should be of type 'data.frame'!")
}
}
if(is.null(li$demand) | length(li$demand) ==0) {
li$demand <- as.numeric(sample(30:100,N,replace=TRUE))
w <- paste("y-Coordinate simulated (y= ",li$demand,").")
if(li$showwarnings) warning(w)
}
if(is.null(li$isDummy)) {
li$isDummy <- rep(FALSE,N)
}
.Object@demand <- as.numeric( li$demand)
.Object@isDummy <- as.logical( li$isDummy)
.Object<-callNextMethod(.Object,data,...)
validObject(.Object)
return(.Object )
})
################################### extract - Method ###################################################
#' @title Extract Methods
#' @name [
#' @aliases [,Customer-method
#' @rdname Extract-methods-2
setMethod("[", "Customer",
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("Customer", df))
}
)
################################### Set - Method ###################################################
#' @title Set Methods
#' @name [<-
#' @aliases [<-,Customer-method
#' @rdname Set-methods-2
#' @param x The Customer
#' @param i row-Index
#' @param j Name or Column index
setReplaceMethod("[",signature(x="Customer"),
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, "Customer")){
#replace the item(s) regarding to i
x$id[i] <- value@id
x$label[i] <- value@label
x$x[i] <- value@x
x$y[i] <- value@y
x$demand[i] <- value@demand
x$isDummy[i] <- value@isDummy
# return new item
return (x)
} else {
if(missing(j)) {
# call the function recursivly
# might throw an error if the conversion is not supported.
x[i] <- as.Customer(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.Customer.list = function(x, ...){return(new("Customer", data=x))}
as.Customer.data.frame = function(x, ...){return(new("Customer", data=x))}
#local convert message
as.data.frame.Customer = 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, demand=x@demand, isDummy = x@isDummy)
if(li$withrownames) rownames(df)<-x@id
return (df)
}
as.list.Customer = function(x, ...){list(id=x@id, label = x@label, x= x@x, y= x@y, demand=x@demand, isDummy = x@isDummy)}
#' @export
setGeneric("as.Customer", function(x, ...) standardGeneric( "as.Customer"))
#' @title Convert Objects to Customers
#' @name as.Customer
#' @param x an Object to convert.
#' @param ... optional parameters
#' @aliases as.Customer,list-method
#' @rdname as.Customer-methods
setMethod("as.Customer", signature(x = "list"), as.Customer.list)
#' @title Convert Objects to Customers
#' @name as.Customer
#' @aliases as.Customer,data.frame-method
#' @rdname as.Customer-methods
setMethod("as.Customer", signature(x = "data.frame"), as.Customer.data.frame)
#' @title Convert Objects to lists
#' @name as.list
#' @aliases as.list,Customer-method
#' @rdname as.list-methods
setMethod("as.list", signature(x = "Customer"), as.list.Customer)
#' @title Convert Objects to data.frames
#' @name as.data.frame
#' @aliases as.data.frame,Customer-method
#' @rdname as.data.frame-methods
setMethod("as.data.frame", signature(x = "Customer"), as.data.frame.Customer)
setAs("data.frame", "Customer", def=function(from){return(as.Customer.data.frame(from))})
setAs("list", "Customer", def=function(from){return(as.Customer.list(from))})
################################### is... - Method ###################################################
#' @title Checks if an Object is as Customer
#' @export
#' @name is.Customer
#' @aliases is.Customer
#' @param x the object to be checked for class \code{\link{Customer}}
#' @param ... optional Parameters (not supported)
setGeneric("is.Customer", function(x, ...) standardGeneric( "is.Customer"))
#' @aliases is.Customer,Customer-method
#' @rdname is.Customer
setMethod( "is.Customer", "Customer", function(x, ...){return(is(x ,"Customer"))})
#' @title How many Customers are included?
#' @name length
#' @aliases length,Customer-method
#' @rdname length
setMethod("length", "Customer",
function(x){
N <- length(x@id)
return(N)
}
)
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.