R/update.R

In bdlp: A Package for Transparent Artificial Data Generation

#' Add an empty cluster to a metadata object
#'
#' @param m A metadata object
#' @return A metadata object with an empty additional cluster
#' @examples
#' require(MASS)
#' m <- new("metadata.metric", 
#'          clusters = list(c1 = list(n = 25, mu = c(4,5), Sigma=diag(1,2)),
#'                          c2 = list(n = 25, mu = c(-1,-2), Sigma=diag(1,2))),
#'          genfunc = mvrnorm)
#' m2 <- addCluster(m)
#' @export
addCluster <- function(m){
  prev <- length(m@clusters)
  new <- paste("cl", prev + 1, sep="")
  eval(parse(text=(paste("m@clusters$", new, " <- formals(m@genfunc)", sep=""))))
  return(m)
}

#' Delete a cluster from a metadata object
#'
#' @param m A metadata object
#' @param clnumber The cluster to delete
#' @return A metadata object
#' @examples
#' require(MASS)
#' m <- new("metadata.metric", 
#'          clusters = list(c1 = list(n = 25, mu = c(4,5), Sigma=diag(1,2)),
#'                          c2 = list(n = 25, mu = c(-1,-2), Sigma=diag(1,2))),
#'          genfunc = mvrnorm)
#' m2 <- deleteCluster(m, 2)
#' @export
deleteCluster <- function(m, clnumber){
  m@clusters <- m@clusters[-clnumber]
  l <- length(names(m@clusters))
  names(m@clusters) <- paste("cl", 1:l, sep="")
  return(m)
}


#' Initialize a new metadata object
#'
#' @param type The data type for the new object
#' @param k Number of clusters
#' @param genfunc The distribution function for data generation
#' @param seed The random number seed parameters for the data generation
#' @return A metadata object
#' @examples
#' require(MASS)
#' initializeObject(type = "metric", k = 3, genfunc = mvrnorm)
#' @export
#' @importFrom methods new
initializeObject <- function(type, k, genfunc, seed = list(100, 
                                      paste(R.version$major, R.version$minor, sep = "."),
                                      RNGkind())){
  
  if(type == "metric") type <- "metadata.metric"
  if(type == "functional") type <- "metadata.functional"
  if(type == "ordinal") type <- "metadata.ordinal"
  if(type == "binary") type <- "metadata.binary"
  if(type == "randomstring") type <- "metadata.randomstring"
  
  cl <- paste("cl", 1:k, sep="")
  clusters <- list()
  clusters <- sapply(cl,function(x) NULL)
  clusters <- lapply(clusters, function(x) formals(genfunc))
  
  new(type, clusters=clusters, seedinfo=seed, genfunc=genfunc)

}

#' Saves a list of metadata objects to a new setup file
#'
#' @param name The name of the new setup (and thus also the filename)
#' @param author Full name of the author
#' @param mail Contact e-mail address of the author
#' @param inst Institution of the author
#' @param cit Reference to the publication where the setup was used, defaults to unpublished
#' @param objects List of metadata objects
#' @param table Info table for the setup
#' @param seedinfo Random number generator parameters for the data sets
#' @param metaseedinfo Random number generator parameters for the metadata
#' @param custom_funcs Custom functions that are needed to generate the meta(data)
#' @param custom_name Custom filename that deviates from the authorYear format
#' @return A .R file that can be processed by \code{create.dataset}
#' @examples
#' require(MASS)
#' a = new("metadata.metric", 
#'         clusters = list(c1 = list(n = 25, mu = c(4,5), Sigma=diag(1,2)),
#'                         c2 = list(n = 25, mu = c(-1,-2), Sigma=diag(1,2))),
#'                         genfunc = mvrnorm)
#' b = new("metadata.metric", 
#'         clusters = list(c1 = list(n = 44, mu = c(1,2), Sigma=diag(1,2)),
#'                         c2 = list(n = 66, mu = c(-5,-6), Sigma=diag(1,2))),
#'                         genfunc = mvrnorm)
#' saveSetup(name="test2002.R", author="Mister Twister", mail="mister.twister@edu.com",
#'            inst="Twister University", cit="Simple Data, pp. 23-24", objects=list(a, b),
#'            table=data.frame(n = c(50, 110), k = c(2,2), shape = c("spherical", "spherical")))  
#' @export
saveSetup <- function(name, author, mail, inst, 
                       cit = "Unpublished", objects, table, 
                       seedinfo = list(100, 
                                      paste(R.version$major, R.version$minor, sep = "."),
                                      RNGkind()), 
                       metaseedinfo = list(100, 
                                      paste(R.version$major, R.version$minor, sep = "."),
                                      RNGkind()), 
                       custom_funcs = NULL, custom_name = NULL){
	
	if(is.null(custom_name))
	  newname <- paste(strsplit(name, ".R")[[1]], ".R", sep="")
	else
	  newname <- custom_name
	  
	funcname <- strsplit(name, ".R")[[1]]
	file.create(newname)
	
	cat("# Simulation setup file generated by \n \n", file = newname)
	cat(paste("# ", author, "\n", "# ", mail, "\n", "# ", inst, "\n \n", sep = ""), file = newname, append = T)
	
	cat(paste(funcname, " <- function(setnr = NULL, seedinfo = ", capture.output(dput(seedinfo)), ", metaseedinfo = ", capture.output(dput(metaseedinfo)),", info = F) { \n \n", sep=""), file=newname, append=T)
    infotable <- capture.output(dput(table))
    cat(paste("  infotable <- ", infotable[1], "\n", sep = ""), file = newname, append=T)
    cat(paste("    ", infotable[-1], "\n", sep = ""), file = newname, append=T)
    cat("\n", file = newname, append=T)
	cat(paste("  reference <- ", strsplit(capture.output(cit), "] ")[[1]][2], "\n \n", sep = ""), file = newname, append=T)
	cat(paste("  if(info == T) return(list(summary=infotable, reference=reference)) \n \n"), file = newname, append=T)
	
	objlength <- length(objects)
	
	cat("  if(is.null(metaseedinfo)) metaseedinfo <- seedinfo \n \n", file=newname, append=T)
	
	cat("  # For a specified seed and setnr, return the respective metadata object \n \n", file = newname, append=T)
	cat(paste("  set.seed(", metaseedinfo[[1]], ") \n", sep=""), file = newname, append=T)
	cat(paste("  RNGversion(\"", metaseedinfo[[2]], "\") \n", sep=""), file = newname, append=T)
	cat(paste("  RNGkind(\"", metaseedinfo[[3]][1], "\",\"", metaseedinfo[[3]][2], "\") \n \n", sep=""), file = newname, append=T)
	
	
	for(i in 1:objlength){
	  cat(paste("  if(setnr == ",  i, ") \n \n", sep =""), file = newname, append=T)
	  cat(paste("    return(", capture.output(dput(objects[[i]]))[1], "\n", sep =""), file = newname, append = T)
	  cat(paste("    ", capture.output(dput(objects[[i]]))[-1], "\n", sep =""), file = newname, append = T)	
	  cat("    )\n", file = newname, append=T)
	}    
	cat("} \n \n", file = newname, append=T)
	
	if(!is.null(custom_funcs)) {
	  cat("# Custom functions: \n \n", file = newname, append=T)
	  
	  for(i in 1:length(custom_funcs)){
	    u <- capture.output(dput(custom_funcs[i]))
	    u[1] <- paste(custom_funcs[i], u[1], sep="")
	    cat(paste(u, "\n \n", sep=""), file = newname, append=T)
	  }  
	}
}