R/rrepast-helper.R

Defines functions SequenceItem df2matrix dfsumcol dffilterby dfround Calibration.GetMemberKeys Calibration.GetMemberList pick.fittest col.sum hybrid.value hybrid.distance lcontains lget

Documented in Calibration.GetMemberKeys Calibration.GetMemberList col.sum df2matrix dffilterby dfround dfsumcol hybrid.distance hybrid.value lcontains lget pick.fittest SequenceItem

##================================================================================
## 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
  }
}
antonio-pgarcia/RRepast documentation built on Feb. 22, 2020, 1:20 a.m.