R/clientmmii.R

Defines functions is.dummy use.simile.at load.model list.objects get.model.property create.model set.model.step create.param.array set.model.parameter consult.parameter.metafile reset.model execute.model get.model.time tcl.paired.to.list tcl.paired.to.array get.value.list get.value.array

Documented in consult.parameter.metafile create.model create.param.array execute.model get.model.property get.model.time get.value.array get.value.list is.dummy list.objects load.model reset.model set.model.parameter set.model.step tcl.paired.to.array tcl.paired.to.list use.simile.at

is.dummy <- function(path.or.handle) {
  any(c("dummy/path", "dummy.dll", "dummy_mh", "dummy_ih", "dummy_ph") ==
      as.character(path.or.handle)[1])
}

use.simile.at <- function(path.to.installation) {
  tcl("set", "::loadedFromR", 1) # lets Tcl client know R is using it
  if (!is.dummy(path.to.installation)) {
    tcl("source", file.path(find.package(package = "Simile"), "exec",
        "client5d.tcl"))
    tcl("UseSimileAt", path.to.installation)
  }
}

load.model <- function(path.to.binary) {
  if (is.dummy(path.to.binary)) {
    "dummy_mh"
  } else {
    tcl("loadmodel", path.to.binary, "R")
  }
}

list.objects <- function(model.handle) {
  if (is.dummy(model.handle)) {
    c("/sector","/sector/output","/sector/flow1","/sector/variation")
  } else {
    as.character(tcl("ListObjPaths", model.handle))
  }
}

get.model.property <- function(model.handle, caption.path, requested.property) {
  if (is.dummy(model.handle)) {
    if (requested.property == "Dims") {
      c(2,5)
    } else {
      "COMPARTMENT"
    }
  } else {
    tcl.result <- tcl("GetModelProperty", model.handle, caption.path,
                      requested.property)
    if (any(c("Dims")==requested.property)) {
# may be more integer cases
      with.trailing.zero <- as.integer(tcl.result)
      with.trailing.zero[-length(with.trailing.zero)] # removes it
    } else if (any(c("MinVal","MaxVal")==requested.property)) {
# may be more integer cases
      as.double(tcl.result)
    } else {
      as.character(tcl.result)
    }
  }
}

create.model <- function(model.handle) {
  if (is.dummy(model.handle)) {
    "dummy_ih"
  } else {
    tcl("CreateModel", model.handle)
  }
}

set.model.step <- function(instance.handle, step.index, step.size) {
  if (!is.dummy(instance.handle)) {
    tcl("c_setstepmodel", instance.handle, step.size, step.index)
  }
}

create.param.array <- function(instance.handle, param.name) {
  if (is.dummy(instance.handle)) {
    "dummy_ph"
  } else {
    tcl("CreateParamArray", instance.handle, param.name)
  }
}

set.model.parameter <- function(param.handle, data, as.enum.types = FALSE) {
  if (!is.dummy(param.handle)) {
  tcl("SetParamArrayFromFlatList", param.handle, data, as.enum.types, 
      dim(data))
  }
}

consult.parameter.metafile <- function(instance.handle, param.file,
                                       target.submodel = "") {
  if (!is.dummy(instance.handle)) {
    tcl("ConsultParameterMetafile", instance.handle, param.file, 
        target.submodel)
  }
}

reset.model <- function(instance.handle, depth, integration.method = "Euler",
                        starting.time = 0) {
  if (!is.dummy(instance.handle)) {
    tcl("DoResetModel", instance.handle, starting.time, integration.method, 
        depth)
  }
}

execute.model <- function(instance.handle, finish.time,
                          integration.method = "Euler", start.time = NA,
                          error.limit = 0, pause.on.event = FALSE) {
  if (!is.dummy(instance.handle)) {
    if (is.na(start.time)) {
      start.time <- get.model.time(instance.handle)
    }
    as.integer(tcl("DoExecuteModel", instance.handle, integration.method,
                   start.time, finish.time, error.limit, pause.on.event))
  }
}

get.model.time <- function(instance.handle) {
  if (is.dummy(instance.handle)) {
    0.0
  } else {
    tcl("GetModelTime", instance.handle)
  }
}

tcl.paired.to.list <- function(paired, as.enum.types) {
  length <- as.integer(tcl("llength", paired))
  if (length==1) {
    if (as.enum.types) {
      as.character(paired)
    } else {
      as.double(paired)
    }
  } else {
    result <- list() # sets none
    for (posn in seq(1,length,by=2)) {
      index <- tcl("lindex", paired, posn-1)
      if (as.enum.types) {
        index <- as.character(index)
      } else {
        index <- as.integer(index)
      }    
      result[[index]] <- tcl.paired.to.list(tcl("lindex", paired, posn),
                                            as.enum.types)
    }
    result
  }
}

tcl.paired.to.array <- function(paired, dims, as.enum.types) {
  # note indices in value from model are ignored, so may be enumerated type
  if (length(dims)) {
    result <- {}
    subDims <- dims[-1] # removes first element
    for (posn in 1:dims[1]) {
      idx <- 2*posn-1
      member <- tcl("lindex", paired, idx)
      result <- c(result, tcl.paired.to.array(member, subDims, as.enum.types))
    }
    array(result,dim=rev(dims))
  } else if (as.enum.types) {
    as.character(paired)
  } else {
    as.double(paired)
  }
}

get.value.list <- function(instance.handle, value.name, as.enum.types = FALSE) {
  if (is.dummy(instance.handle)) {
    paired <- "1 40.76667783660071 2 37.52906643918561 3 33.820213413335914 4 29.694134498874085";
  } else {
    paired <- tcl("GetPairedValues", instance.handle, value.name, as.enum.types)
  }
  tcl.paired.to.list(paired, as.enum.types)
}

get.value.array <- function(instance.handle, value.name, as.enum.types = FALSE) {
  if (is.dummy(instance.handle)) {
    dims <- 10
    paired <- "1 0.8414710 2 0.9092974 3 0.1411200 4 -0.7568025 5 -0.9589243 6 -0.2794155 7 0.6569866 8 0.9893582 9 0.4121185 10 -0.5440211"
  } else {
    i.m.list <- tcl("array", "get", "::modelTypes", instance.handle)
    dims <- get.model.property(tcl("lindex", i.m.list, 1), value.name, "Dims")
    if (any(is.na(dims))) {
      stop("This value is in a variable-membership submodel --
use get.value.list instead")
    }
    paired <- tcl("GetPairedValues", instance.handle, value.name, as.enum.types)
  }
  tcl.paired.to.array(paired, dims, as.enum.types)
}

Try the Simile package in your browser

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

Simile documentation built on May 2, 2019, 6:52 a.m.