##================================================================================
## This file is part of the R/Repast package - R/Repast
##
## (C)2016, 2017 Antonio Prestes Garcia <@>
## For license terms see DESCRIPTION and/or LICENSE
##
## @file: rrepast-helper.R
##
## This file contains helper functions
##================================================================================
#' @title SequenceItem
#'
#' @description Generate a sequence from min to max using an increment
#' based on the number of of elements in v
#'
#' @param v A column of n x k design matrix
#' @param min The lower boundary of range
#' @param max The uper boundary of range
#'
#' @return A sequence between min and max value
#'
#' @export
SequenceItem<- function(v,min,max) {
n<- length(v)
delta<- (max-min)/(n-1)
return(seq(min,max,delta))
}
#' @title df2matrix
#'
#' @description This function converts data frames to matrix data type.
#'
#' @param d The data frame
#' @param n The column names to be converted. Null for all data frame columns
#'
#' @return The data frame converted to a matrix
#'
#' @export
df2matrix<- function(d,n=c()) {
if(length(n) == 0) {
n<- names(d)
}
m<- c()
for(k in n) {
m<- cbind(m,as.matrix(d[,k]))
}
colnames(m)<- n
return(m)
}
#' @title dfsumcol
#'
#' @description Sum data frame columns but tho
#'
#' @param d The data frame
#' @param lst Skip columns included. Sum columns NOT included
#' @param invert Sum only the columns included in \code{lst}
#'
#' @return The original data frame with a new column (sum) holding the sum
#'
#' @export
dfsumcol<- function(d,lst=c(),invert=FALSE) {
v<- as.data.frame(d)
s<- NULL
op<- "!"
if(invert) {
identity<- function(x) {x}
op<- "identity"
}
for(key in colnames(v)) {
if(match.fun(FUN=op)(toupper(key) %in% toupper(lst))) {
if(is.null(s)){
s<- v[, key]
} else {
s<- s + v[, key]
}
}
}
v$total<- s
## Return the same type of original data
if(is.matrix(d)) {
v<- as.matrix(v)
}
return(v)
}
#' @title dffilterby
#'
#' @description Selects a subset of a data frame, filtering by
#' column values.
#'
#' @param d The data frame holding data to be filtered
#' @param key The column name for selection valuas
#' @param values The collection of values used to filter the data set
#'
#' @return The filtered data set
#'
#' @export
dffilterby<- function(d, key, values=c()) {
d<- as.data.frame(d)
o<- c()
for(v in values) {
o<- rbind(o,d[d[,colnames(d) == key] %in% v,])
}
return(o)
}
#' @title dfround
#'
#' @description Round all numeric columns of a data frame
#'
#' @param d The data frame
#' @param p The number of decimal digits to be keept
#'
#' @return A data frame with rounded columns
#'
#' @export
dfround<- function(d, p) {
return(sapply(d[,sapply(d,is.numeric)],round,digits=p))
}
#' @title Calibration.GetMemberKeys
#'
#' @description Gets the list of keys (the factor names)
#'
#' @param obj An instance of the object returned by \code{Easy} methods
#'
#' @return The collection of keys
#' @export
Calibration.GetMemberKeys<- function(obj) {
if(!"variable" %in% colnames(obj)) {
stop("Not an instance of a Easy.Calibration return!")
}
unlist(obj[,"variable"])
}
#' @title Calibration.GetMemberList
#'
#' @description Gets the member list value
#'
#' @param obj An instance of the object returned by \code{Easy} methods
#' @param key The key value
#' @param name The column name
#'
#' @return The member list
#' @export
Calibration.GetMemberList<- function(obj, key, name) {
if(!"variable" %in% colnames(obj)) {
stop("Not an instance of a Easy.Calibration return!")
}
obj[(obj[,"variable"] == key),name][[1]]
}
#' @title pick.fittest
#'
#' @description Choose the best solutions minimizing the objective function
#'
#' @param out The output data set holding the values of goals
#' @param goals The column names which must be used as goal
#' @param n The number of solutions
#'
#' @return The n rows holding the best results
#'
#' @export
pick.fittest<- function(out, goals=c(), n=4) {
out<- as.data.frame(out)
## -- Check if out was generated by RunExperiment
if(!"pset" %in% colnames(out)) {
stop("Invalid data set!")
}
## --- Adjusting defaults
n<- ifelse(n > nrow(out),nrow(out),n)
goals<- ifelse(length(goals) == 0,c(2),goals)
out<- out[order(out[,goals]), ]
return(out[1:n,])
}
#' @title col.sum
#'
#' @description Sum all columns but one (pset) of a data frame
#'
#' @param d The data frame
#' @param skip The columns which should not be included in the sum
#'
#' @return The original data frame with a new column (sum) holding the sum
#'
#' @export
col.sum<- function(d,skip=c()) {
v<- as.data.frame(d)
s<- NULL
## -- always skip pset
if(!"pset" %in% skip) {
skip<- c("pset",skip)
}
## -- always skip total
if(!"total" %in% skip) {
skip<- c("total",skip)
}
v<- dfsumcol(v,skip)
return(v)
}
#' @title hybrid.value
#'
#' @description A simple helper function for generating the input list for
#' the function 'hybrid.distance'. This list must hold the value and a range
#' centered over the value.
#'
#' @param value The reference value
#' @param distance The distance interval.
#'
#' @return The list holding the value and the interval 'min --- value --- max'
#'
#' @export
hybrid.value<- function(value, distance) {
vv<- value * distance
list(value=value, min=(value-vv), max=(value+vv))
}
#' @title hybrid.distance
#'
#' @description Calculates the distance between some value a reference
#' target value. It is an hybrid distance because when the value falls
#' whithin a reference range the distance is 0, otherwise the distance
#' between the value and the reference value is calculated using the user
#' provided distance function.
#'
#' @param value The value which will be compared against the reference
#' @param reference The reference value. It should be a list holding the value, the range of values.
#' @param FUN The distance function. The default is the NRMSD
#'
#' @return The distance metric
#'
#' @export
hybrid.distance<- function(value, reference, FUN=AoE.NRMSD) {
if(!is.list(reference)) stop("reference must be list", call. = FALSE)
if(is.null(reference[["value"]])) stop("reference must a member named 'value'", call. = FALSE)
if(is.null(reference[["min"]])) stop("reference must a member named 'min'", call. = FALSE)
if(is.null(reference[["max"]])) stop("reference must a member named 'max'", call. = FALSE)
FUN( ifelse(( value >= reference$min & value <= reference$max ), reference$value, value), reference$value )
}
#' @title lcontains
#'
#' @description Cheks if a list contains a name
#'
#' @param l The list object
#' @param n The item name
#'
#' @return Boolean TRUE if name is found on list
#'
#' @export
lcontains<- function(l, n) {
if(is.list(l)) {
!is.null(l[[ n ]])
} else {
warning("The parameter is no a list!")
FALSE
}
}
#' @title get
#'
#' @description Retrieve the value for a list item
#'
#' @param l The list object
#' @param n The item name
#'
#' @return The item value
#'
#' @export
lget<- function(l, n) {
if(lcontains(l,n)) {
l[[ n ]]
} else {
NULL
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.