R/getIdentifier.R

In pik-piam/validation: MAgPIE validation library

.getIdentifier<-function(func,...,ignore.args=NULL,choose.args=NULL,get=TRUE,return_arguments=FALSE){
  if(get && (!is.null(ignore.args)||!is.null(choose.args))){
    warning("ignore.args and choose.args will be ignored because get is TRUE.")
    ignore.args<-NULL
    choose.args<-NULL
  }
    if(any(!c(ignore.args,choose.args)%in% names(formals(func)))){
      return(NULL)
    }
  ##################################################################
  #Check whether the function func belongs to the magpie library
  ##################################################################
  get_funcname<-function(func){
    for(i in 0:sys.nframe()){
      if(deparse(substitute(func,env=sys.frame(which=sys.parent(n=i)))) %in% ls("package:magpie")){
        return(deparse(substitute(func,env=sys.frame(which=sys.parent(n=i)))))
      }
    }
    return(NULL)
  }
  if(!get_funcname(func) %in% ls("package:magpie")) stop("Function '",get_funcname(func),"' does not belong to the magpie library")
  ###################################################################
  #Check whether the function can be called with the values specified for the arguments.
  ###################################################################
  if(!get){
    tmp<-try(func(...)) 
    if(is(tmp,"try-error"))stop("No correct set of arguments for function '",get_funcname(func),"' specified")
  }
  ###################################################################
  #Define the full set of arguments including ... arguments and not specified default values from func
  ###################################################################
  lib_arguments<-formals(func)
  if(length(grep("\\.\\.\\.",names(lib_arguments)))>0) lib_arguments[["..."]]<-NULL
  get_data_arguments<-list(...)
  if(length(get_data_arguments)>0){
    tmp<-pmatch(names(get_data_arguments),names(lib_arguments))
    names(get_data_arguments)[which(!is.na(tmp))]<-match.arg(names(get_data_arguments),names(lib_arguments),several.ok=T)
  }
  arguments<-lib_arguments
  for(arg in names(get_data_arguments)){
    arguments[[arg]]<-get_data_arguments[[arg]]
  }  
  if(return_arguments) return(arguments)
  ###############################################################
  #Define the data identifier for the mapping.
  ###############################################################
  #It looks like the function call
  #except that there are no quotes for string arguments
  #And the value of each argument can also be ##IGNORE## or ##CHOOSE##
  #The arguments file, level and gdx are not part of the identifier
  #Example: land(types=(crop|##IGNORE##),sum=(FALSE|##IGNORE##))
  identifier<-arguments[which(!names(arguments) %in% c("gdx","file","level"))]
#   return(identifier)
# }
  #Escape special characters in arguments that might be interpreted as regular expressions
  special_chars<-c(".","(",")")
  tmp_func<-function(x,pattern){
    if(is.null(x)){
      return(x)
    } else {
      return(gsub(paste("\\",pattern,sep=""),paste("\\\\",pattern,sep=""),x))
    }
  }
  if(get){
    for(i in special_chars){
      identifier<-lapply(identifier,tmp_func,pattern=i)
      names(identifier)<-gsub(paste("\\",i,sep=""),paste("\\\\",i,sep=""),names(identifier),perl=T)
    }
  }
  for( i in ignore.args){
    identifier[[i]]<-"##IGNORE##"
  }
  for( i in choose.args){
    identifier[[i]]<-"##CHOOSE##"
  }
  #Add the ##IGNORE## and ##CHOOSE## string to all arguments if get==TRUE. If any argument has length>1, the brackets in c(arg1,arg2)
  #have to be replaced by \\(, \\)
  add_flags<-function(x){
    if(is.null(x)) x<-"NULL"
    return(paste("(",sub("(","\\(",sub(")","\\)",paste(list(x),sep="",collapse=","),fixed=TRUE),fixed=TRUE),"|##IGNORE##|##CHOOSE##)",sep=""))
  }
  if(get)identifier<-lapply(identifier,add_flags)
  
  identifier<-paste(names(identifier),identifier,sep="=",collapse=",")
  if(!get){
    identifier<-paste(get_funcname(func),"(",identifier,")",sep="")
  } else {
    identifier<-paste(get_funcname(func),"\\(",identifier,"\\)",sep="")
  }
    
  return(identifier)  
}