R/RRepast.R

Defines functions BuildParameterSet ApplyFactorRange GetFactorsSize AddFactor SaveSimulationData SetResultsParameters GetResultsParameters AddResults SetResults GetResults ClearResults GetSimulationParameters SetSimulationParameter SetSimulationParameters UpdateDefaultParameters GetSimulationParameterType GetOutput getExperimentDataset getExperimentOutput getExperimentParamSet RunExperiment Run Load Model onLoad

Documented in AddFactor AddResults ApplyFactorRange BuildParameterSet ClearResults getExperimentDataset getExperimentOutput getExperimentParamSet GetFactorsSize GetOutput GetResults GetResultsParameters GetSimulationParameters GetSimulationParameterType Load Model Run RunExperiment SaveSimulationData SetResults SetResultsParameters SetSimulationParameter SetSimulationParameters UpdateDefaultParameters

##================================================================================
## This file is part of the rrepast package - R/Repast interface API
##
## (C)2015 Antonio Prestes Garcia <@>
## For license terms see DESCRIPTION and/or LICENSE
##
## $Id$
##================================================================================


# ------------------------------------------------------------
# .onLoad, Hook for loading package namespace
#
# ------------------------------------------------------------
.onLoad<- function(libname, pkgname) {
  #packageStartupMessage("R/Repast: Integrating Repast Models into R\n")
  assign("pkg.globals", new.env(), envir=parent.env(environment()))

  # Internal variables
  assign("pkg.basedir", NA, pkg.globals)
  assign("pkg.modeldir", NA, pkg.globals)
  assign("pkg.scenariodir", NA, pkg.globals)
  assign("pkg.modellibdir", NA, pkg.globals)
  assign("pkg.id", NA, pkg.globals)

  # global simulation results
  assign("pkg.parameters", data.frame(), pkg.globals)
  assign("pkg.results", data.frame(), pkg.globals)

  # progress bar internals
  assign("pkg.progressbar", NULL, pkg.globals)
  assign("pkg.progressbar.enabled", FALSE, pkg.globals)

  # default values for model
  assign("pkg.outputdir",paste0(Sys.getenv("TMP"),"/rrepast-deployment/"), pkg.globals)
  assign("pkg.repastlibdir", "/repast.simphony/", pkg.globals)
  assign("pkg.java.parameters","-server -Xms512m -Xmx1024m", pkg.globals)

  # default key for Repast random seed
  assign("pkg.randomSeed","randomSeed", pkg.globals)

  # The Random Seed. You may want to change this.
  set.seed(exp(1)*10^6)

  # Define funcions which are not present in ond R versions
  compatibility()
}


#' @title The easy API for model initilization
#'
#' @description Instantiate a repast model from the model dir without
#' loading the scenario file.
#'
#' @details This is the entry point for model execution. Typically
#' any model execution will start with this function which encapsulates
#' all low level calls for model initialization. In order to perform
#' simulations with repast from R code only \code{Model} and a
#' few more function calls are required: \code{\link{Load}},
#' \code{\link{Run}}. Finally the output of model is managed with
#' functions \code{\link{GetResults}} and \code{\link{SaveSimulationData}}.
#'
#' @param modeldir The installation directory of some repast model
#' @param maxtime The total simulated time
#' @param dataset The name of any model aggregate dataset
#' @param load If true instantiate model and load scenario
#'
#' @return Returns the instance of repast model
#' @examples \dontrun{
#'    d<- "C:/usr/models/your-model-directory"
#'    m<- Model(d)}
#'
#' @references
#' [1] North, M.J., N.T. Collier, and J.R. Vos, "Experiences Creating Three Implementations of the Repast Agent Modeling Toolkit," ACM Transactions
#' on Modeling and Computer Simulation, Vol. 16, Issue 1, pp. 1-25, ACM,
#' New York, New York, USA (January 2006).
#' @export
Model<- function(modeldir="",maxtime=300,dataset="none", load=FALSE) {
  if(dir.exists(modeldir)) {
    # Configure all required directory based on their default locations
    configModelDirs(modeldir)

    # Initilialized JVM
    # Setup classpath inferring default values from modeldir
    jvm.init()

    # Creating an engine instance
    e<- Engine()

    # Configure the total amount of time to be simulated
    Engine.endAt(e,maxtime)

    # Configure the dataset
    Engine.SetAggregateDataSet(e,dataset)

    if(load == TRUE) {
      Load(e)
    }

    return(e)
  } else {
    stop(paste0("The model directory does not exist: ", modeldir))
  }
}

#' @title The Scenario loader
#'
#' @description Loads the model's scenario. This function must be
#' called before running the model.
#'
#' @examples \dontrun{
#'    d<- "C:/usr/models/your-model-directory"
#'    m<- Model(d)
#'    Load(m)}
#'
#' @param e An engine object instance
#'
#' @export
Load<- function(e) {
  Engine.LoadModel(e,getScenarioDir())
  setId(Engine.getId(e))
}

#' @title Run simulations
#'
#' @description This function executes the time steps of an
#' instantiated model. The number of replications of model
#' runs can be specified by the function parameter. The seed
#' parameter may be omitted and will be generated internally.
#' If provided, the seed collection, must contain the same
#' number of \code{r} parameter.
#'
#' @param e An engine object instance
#' @param r The number of experiment replications
#' @param seed The random seed collection
#'
#' @return The model output dataset
#'
#' @examples \dontrun{
#'    d<- "C:/usr/models/your-model-directory"
#'    m<- Model(d)
#'    Load(m)
#'    Run(m,r=2) # or Run(m,r=2,seed=c(1,2))}
#'
#' @importFrom stats runif
#' @export
Run<- function(e,r=1,seed=c()) {
  # The default behaviour is if seed set was
  # not provided generate a suitable set of
  # random seeds for the number of replications.
  if(length(seed) == 0) {
    seed= runif(r,-10^8,10^8)
  } else if(length(seed) != r) {
    stop("The provided set of random numbers doesn't match replications!")
  }

  # Gets the current set of parameters
  p<- GetSimulationParameters(e)

  # Clear result repository
  ClearResults()

  SetResultsParameters(p)

  ## --- Progress Bar initialization
  PB.init(1, r)

  results<- c()

  for(i in 1:r) {

    if(r > 1) {
      ## --- Setting the random seed for experiment replication
      Engine.setParameter(e,getKeyRandom(),as.integer(seed[i]))
    }

    ## --- Pass the control to Repast to run simulation
    Engine.RunModel(e)

    data<- GetOutput(e)

    ## --- Just for debug: print(paste0("run= ", i, " / rows=", nrow(data)))

    # Sets the current run number
    data$run<- i

    # Add replication data
    AddResults(data)

    results<- rbind(results,data)

    # Update progress bar
    PB.update(i)

    ##Engine.resetModelOutput(e)
  }
  ## --- Progress Bar clean up
  PB.close()

  return(results)
}

#' @title Run an experimental setup
#'
#' @description Run the model multiple times for different parameters
#' given by design matrix function parameter.
#'
#' @details The FUN function must return zero for perfect fit and values
#' greater than zero otherwise.
#'
#' @param e An engine object instance
#' @param r The number of experiment replications
#' @param design The desing matrix holding parameter sampling
#' @param FUN THe calibration function.
#'
#' @examples \dontrun{
#'    my.cost<- function(params, results) { # your best fit calculation, being 0 the best metric.  }
#'    d<- "c:/usr/models/your-model-directory"
#'    m<- Model(d,dataset="ds::Output")
#'    Load(m)
#'    f<- AddFactor(name="cyclePoint",min=40,max=90)
#'    f<- AddFactor(factors=f, name="conjugationCost",min=1,max=80)
#'    d<- LatinHypercube(factors=f)
#'    p<- GetSimulationParameters(e)
#'    exp.design<- BuildParameterSet(d,p)
#'    v<- RunExperiment(e,r=1,exp.design,my.cost) }
#'
#' @return A list with output and dataset
#'
#' @export
RunExperiment<- function(e, r=1, design, FUN) {
  paramset<- c()
  output<- c()
  dataset<- c()

  psets<- nrow(design)

  ## --- Progress Bar initialization
  PB.init(psets, r)

  for(i in 1:psets) {
    d<- design[i,]

    # -- Set parameters for next model 'Run'
    SetSimulationParameters(e, d)

    # -- Update progress bar pset value
    PB.pset(i)

    # -- Run model with current parameter set
    results<- Run(e,r)

    ## ----- [2017/04/01] Possible bug
    ##results<- GetResults()

    # -- The user provided calibration function.
    # -- Calibration function must return 0 for perfect fit between
    # -- observed and experimental data.
    calibration<- FUN(d,results)

    if(is.null(calibration)) {
      stop("Invalid user provided calibration function!")
    }

    # -- The 'pset' is the paramter set id
    pset<- i

    paramset<- rbind(paramset,cbind(pset,d))
    output<- rbind(output,cbind(pset,calibration))
    dataset<- rbind(dataset,cbind(pset,results))
  }

  ## --- Progress Bar clean up
  PB.close()

  return(list(paramset=paramset, output=output, dataset=dataset))
}

#' @title Helper function to get experiment \code{paramset}
#'
#' @description The RunExperiment function returns a list holding
#' the \code{paramset}, \code{output} and \code{dataset} collection.
#' The \code{paramset} collection contains the parameters used for
#' running the experimental setup. The \code{output} has the results
#' from user provided calibration function. The \code{dataset}
#' collection has the raw output of 'Repast' aggregated dataset.
#'
#' @examples \dontrun{
#'    d<- "C:/usr/models/your-model-directory"
#'    m<- Model(d)
#'    ...
#'    e<- RunExperiment(e,r=1,exp.design,my.cost)
#'    p<- getExperimentParamSet(e)}
#'
#' @param e The experiement object returned by \code{\link{RunExperiment}}
#'
#' @return The reference to \code{output} container.
#' @export
getExperimentParamSet<- function(e) {
  v<- e$paramset
  return(v)
}

#' @title Helper function to get experiment \code{output}
#'
#' @description The RunExperiment function returns a list holding
#' the \code{paramset}, \code{output} and \code{dataset} collection.
#' The \code{paramset} collection contains the parameters used for
#' running the experimental setup. The \code{output} has the results
#' from user provided calibration function. The \code{dataset}
#' collection has the raw output of 'Repast' aggregated dataset.
#'
#' @param e The experiement object returned by \code{\link{RunExperiment}}
#'
#' @return The reference to \code{output} container.
#' @export
getExperimentOutput<- function(e) {
  v<- e$output
  return(v)
}

#' @title Helper function to get experiment \code{dataset}
#'
#' @description The RunExperiment function returns a list holding
#' the \code{paramset}, \code{output} and \code{dataset} collection.
#' The \code{paramset} collection contains the parameters used for
#' running the experimental setup. The \code{output} has the results
#' from user provided calibration function. The \code{dataset}
#' collection has the raw output of 'Repast' aggregated dataset.
#'
#' @param e The experiement object returned by \code{\link{RunExperiment}}
#'
#' @return The reference to \code{dataset} container.
#' @export
getExperimentDataset<- function(e) {
  v<- e$dataset
  return(v)
}

#' @title Gets the output
#'
#' @description  Returns the results of a model a data.frame from the last
#' RUN. Should be used only if model replication is equal to 1,
#' otherwise GetResults must be used.
#'
#' @param e An engine object instance
#'
#' @return Returns a data.frame with output data
#'
#' @examples \dontrun{
#'    d<- "C:/usr/models/your-model-directory"
#'    m<- Model(d)
#'    ...
#'    data<- GetOutput(m)}
#'
#' @importFrom utils read.csv
#' @export
GetOutput<- function(e) {
  c<- textConnection(Engine.GetModelOutput(e))
  read.csv(c)
}

#' @title GetSimulationParameterType
#'
#' @description Returns the declared parameter type.
#'
#' @param e An instance of 'Engine' object
#' @param k The parameter name
#'
#' @return The parameter type as string
#' @export
GetSimulationParameterType<- function(e, k) {
  Engine.getParameterType(e, k)
}

#' @title UpdateDefaultParameters
#'
#' @description Modify the value of the default parameters
#' which should be kept fixed
#'
#' @examples \dontrun{
#'    d<- "C:/usr/models/your-model-directory"
#'    m<- Model(d)
#'    Load(m)
#'
#'    p<- c(name1=value1, name2=2)
#'    UpdateDefaultParameters(m,p)}
#'
#' @param e An engine object instance
#' @param p The collection of model fixed paramters to change
#'
#' @export
UpdateDefaultParameters<- function(e, p) {
  if(is.null(e)) {
    stop("Engine object is null!")
  }

  parameters<- GetSimulationParameters(e)
  for(key in names(p)) {
    if(key %in% names(parameters)) {
      value<- sprintf("%s",p[key])
      SetSimulationParameter(e, key, value)
    } else {
      print(sprintf("The model does not have a paramter with name [ %s ]",key))
    }
  }
}

#' @title Set parameters for running model
#'
#' @description Modify the repast model parameters with
#' values provided in parameter 'p' which is a data frame
#' with just one row.
#'
#' @param e An engine object instance
#' @param p A data frame with simulation parameters
#'
#' @export
SetSimulationParameters<- function(e, p) {
  if(is.null(e)) {
    stop("Engine object is null!")
  }

  for(key in names(p)) {
    value<- p[1,key]
    if(is.factor(value)) {
      value<- levels(value)
    }

    ## Modify the default set of parameters
    SetSimulationParameter(e, key, value)
  }
}

#' @title SetSimulationParameter
#'
#' @description Modify model's default parameter collection
#'
#' @param e An engine object instance
#' @param key The paramter name
#' @param value The parameter value
#'
#' @export
SetSimulationParameter<- function(e, key, value) {
  if(is.null(e)) {
    stop("Engine object is null!")
  }

  keys<- names(GetSimulationParameters(e))

  # Verify that "key" is a valid model parameter
  if(key %in% keys) {
  # Try to coerce the value to a type for safety
    switch(typeof(value),
      double = {
        #print(paste0("double", key,"<- ",value))
        value<- as.double(value)
      },

      integer = {
        #print(paste0("integer", key,"<- ",value))
        value<- as.integer(value)
      },

      character = {
         #print(paste0("character", key,"<- ",value))
         value<- as.character(value)
       })
    Engine.setParameter(e,key,value)
  }
}

#' @title Gets the simulation parameters
#'
#' @description Returns a dataframe with the current set of input
#' parameters for the last model run.
#'
#' @param e An engine object instance
#'
#' @return A data frame with simulation parameters
#'
#' @export
GetSimulationParameters<- function(e) {
  keys<- ""
  values<- ""
  names<- Engine.getParameterNames(e)
  for(n in names) {
    v<- Engine.getParameterAsString(e,n)
    if(nchar(keys) == 0){
      keys<- n
      values<- v
    } else {
      keys<- paste0(keys,",",n)
      values<- paste0(values,",",v)
    }
  }
  b<- rbind(keys,values)
  c<- textConnection(b)
  read.csv(c)
}

#' @title Clear the results data.frame
#'
#' @description This function is called automatically every
#' time Run method is called.
#'
#' @export
ClearResults<- function() {
  assign("pkg.results", data.frame(), pkg.globals)
  assign("pkg.parameters", data.frame(), pkg.globals)
}

#' Returns the model results
#'
#' @export
GetResults<- function() {
  return(get("pkg.results", pkg.globals))
}

#' Stores a data.frame
#'
#' @param d A data frame containing one replication data
#'
#' @export
SetResults<- function(d) {
  assign("pkg.results", d, pkg.globals)
}

#' @title Concatenate results of multiple runs
#'
#' @description This function stores the output
#' of the last model execution and it is intended
#' to be used internally.
#'
#' @param d A data frame containing one replication data
#'
#' @export
AddResults<- function(d) {
  r<- GetResults()
  SetResults(rbind(r,d))
}

#' @title Gets the parameters
#'
#' @description Returns the current set of paramters used
#' for the last model run.
#'
#' @return A data.frame with parameters of the model.
#'
#' @export
GetResultsParameters<- function() {
  return(get("pkg.parameters", pkg.globals))
}

#' @title Sets the parameters
#'
#' @description Save the current set of paramters used
#' for the last model run.
#'
#' @param d A data.frame with parameter values
#'
#' @export
SetResultsParameters<- function(d) {
  assign("pkg.parameters", d, pkg.globals)
}

#' @title Saving simulation output
#'
#' @description Saves the simulation results of last call to Run(e)
#' function.
#'
#' @details The model must have been initialized or user must call
#' \code{setId} explicitelly.
#'
#' @param as The desired output type, must be csv or xls
#' @param experiment The experiment output
#'
#' @return The id of saved data
#'
#' @importFrom xlsx write.xlsx
#' @importFrom digest digest
#' @importFrom utils write.csv
#' @export
SaveSimulationData<- function(as="csv", experiment=NULL) {
  # Creating output dir if needed
  createOutputDir()
  filename<- getId()
  if(is.na(filename)) {
    stop("Model was not initialized correctly!")
  }

  paramset<- NULL
  output<- NULL
  dataset<- NULL

  if(!is.null(experiment)) {
    paramset<- getExperimentParamSet(experiment)
    output<- getExperimentOutput(experiment)
    dataset<- getExperimentDataset(experiment)

  } else {
    # The parameters of current simultation output
    paramset<- GetResultsParameters()

    # The results of simulation run
    dataset<- GetResults()
  }



  hash <- digest(Sys.time(), algo="crc32")
  f0<- paste0(getOutputDir(),tolower(filename),"-paramset-",hash)
  f1<- paste0(getOutputDir(),tolower(filename),"-output-",hash)
  f2<- paste0(getOutputDir(),tolower(filename),"-dataset-",hash)

  switch(as,
         csv = {
           f0<- paste0(f0,".csv")
           f1<- paste0(f1,".csv")
           f2<- paste0(f2,".csv")
           write.csv(paramset, f0, row.names=FALSE)
           if(!is.null(output)) {
             write.csv(output, f1, row.names=FALSE)
           }
           write.csv(dataset, f2, row.names=FALSE)
         },
         xls = {
           f0<- paste0(f0,".xlsx")
           f1<- paste0(f1,".xlsx")
           f2<- paste0(f2,".xlsx")

           write.xlsx(paramset, f0)
           if(!is.null(output)) {
             write.xlsx(output, f1)
           }
           write.xlsx(dataset, f0)
         })
  return(hash)
}

#' @title Adds a paramter to factor collection
#'
#' @description Builds up the factor collection.
#'
#' @param factors The current factor collection
#' @param lambda The function to apply FUN(p,min,max)
#' @param name The name of factor
#' @param min The minimun of parameter p
#' @param max The maximun of parameter p
#'
#' @examples \dontrun{
#'    f<- AddFactor(name="Age",min=20,max=60)
#'    f<- AddFactor(factors=f, name="Weight",min=50,max=120)}
#'
#' @return The collection of created factors
#'
#' @export
AddFactor<- function(factors=c(), lambda="qunif",name, min, max) {
  if(max < min) {
    stop("Invalid factor range!")
  }

  # if parameter already existe replace the current value
  rrow<- c(lambda=lambda,name=name,min=min,max=max)
  rownames(rrow)<- NULL
  if(length(factors) > 0 && factors[,"name"] == name) {
    i<- which(factors[,"name"] == name)
    factors[i,]<- c(rrow)
  } else {
    factors<- rbind(factors,c(rrow))
  }
  return(factors)
}

#' @title Get the number of factors
#'
#' @description Returns the total number of factors
#'
#' @param factors A collection of factors created with AddFactor
#'
#' @return The number of parameters in factors collection
#'
#' @export
GetFactorsSize<- function(factors) {
  n<- nrow(factors)
  if(is.null(n)) n<- 0
  return(n)
}

#' @title Corrects the LHS design matrix
#'
#' @description Correct the LHS sampling matrix for a
#' specific range applying the lambda function. The default
#' value of 'lambda' is 'qunif'.
#'
#' @param design The LHS design matrix
#' @param factors THe collection of factors
#'
#' @return The corrected design matrix
#'
#' @export
ApplyFactorRange<- function(design, factors) {
  k<- GetFactorsSize(factors)
  d<- sapply(1:k, function(p) {match.fun(factors[p,"lambda"])(design[,p],as.numeric(factors[p,"min"]),as.numeric(factors[p,"max"]))})

  if(is.null(nrow(d))) {
    ## --- Handle the case where sample size is 1
    d<- as.data.frame(t(d))
  } else {
    ## --- Handle the case where sample size > 1
    d<- as.data.frame(d)
  }

  names(d)<- factors[,"name"]
  return(d)
}

#' @title Builds the simulation parameter set
#'
#' @description Merges the design matrix with parameters which
#' will be keep fixed along simulation runs.
#'
#' @param design The experimental desing matrix for at least one factor
#' @param parameters All parameters of the repast model.
#'
#' @return A data frame holding all parameters required for running the model
#'
#' @examples \dontrun{
#'    modeldir<- "c:/usr/models/BactoSim(HaldaneEngine-1.0)"
#'    e<- Model(modeldir=modeldir,dataset="ds::Output")
#'    Load(e)
#'
#'    f<- AddFactor(name="cyclePoint",min=40,max=90)
#     f<- AddFactor(factors=f, name="conjugationCost",min=1,max=80)
#'
#'    p<- GetSimulationParameters(e)
#'
#'    d<- LatinHypercube(factors=f)
#'
#'    p1<- BuildParameterSet(d,p)}
#'
#' @export
BuildParameterSet<- function(design, parameters) {
  v<- as.data.frame(design)
  tmp.p<- parameters
  for(n in names(v)) {
    # Drop parameters columns which are in design matrix
    tmp.p[n]<- NULL
  }

  # Now join two data frames
  for(i in 1:length(names(tmp.p))) {
    v<- cbind(tmp.p[i],v)
  }
  return(v)
}

Try the rrepast package in your browser

Any scripts or data that you put into this service are public.

rrepast documentation built on May 29, 2017, 8:47 p.m.