Nothing
# Method checking works as follows:
# 1. Method being checked passes a list of the EXPECTED arguments and the
# arguments the user has passed
# 2. generate+list_of_checks generates the list of functions that should
# be called based on the expected arguments
# 3. These functions are called sequentially by execute_checks, until
# either one fails and false is returned, or all pass & true is returned
# 4. As the functions are called from a list, it is vital these all have
# the same input argument structure. If need be, we'll need to tailor the
# function internally
#' Wrapper function called by all spartan methods to check input pre-execution
#'
#' @param argNames Expected argument names for the calling function
#' @param arguments User input to the called function
#' @return Boolean stating whether the input checks pass or fail
check_input_args <- function(argNames, arguments)
{
# If processing multiple timepoints, the check will already have been done
# and no point doing it again, so return TRUE
#print(arguments)
if(!is.null(eval(arguments$check_done))) {
if(eval(arguments$check_done)) {
return(TRUE)
}
}
else {
# Generate list of checks
check_methods_to_call <- generate_list_of_checks(argNames)
# Execute
check_result <- execute_checks(check_methods_to_call,
arguments, argNames)
return(check_result)
}
}
#' Defines which functions to call to check an input argument.
#'
#' This creates a list of check functions to call for the input arguments
#' for a spartan function. This is using the expected argument names,
#' provided by the calling function
#' @param argNames Expected argument names for the calling function
#' @return List of check functions that should be called to check input
generate_list_of_checks <-function(argNames)
{
argList <- NULL
# We initialise the length of the list, but in reality this could be
# longer, if some methods require more than one check. As such we keep
# a list index count
check_methods_to_call <- vector("list", length(argNames))
list_index <- 1
for(arg in 1:length(argNames))
{
# FILEPATH can now be null (with connection to DB and robospartan), so now is not checked
#if(argNames[arg] == "FILEPATH")
# check_methods_to_call[[list_index]] = check_filepath_exists # TAKES ALL ARGS FIXED
if(argNames[arg] == "SAMPLESIZES")
check_methods_to_call[[list_index]] = check_list_all_integers # TAKES ALL ARGS FIXED
# KA in development of roboSpartan this caused issues, so attempting removal of PARAMETERS. May need to go back here below
else if(argNames[arg] %in% c("MEASURES","MEASURE_SCALE"))
check_methods_to_call[[list_index]] = check_text_list # TAKES ALL ARGS FIXED
# Same as above, input checking not working with RoboSpartan, so NUMSAMPLES and NUMCURVES removed from below
else if(argNames[arg] %in% c("NUMSUBSETSPERSAMPLESIZE","NUMRUNSPERSAMPLE","EXPERIMENT_REPETITIONS"))
check_methods_to_call[[list_index]] = check_argument_positive_int # TAKES ALL ARGS FIXED
else if(argNames[arg] %in% c("ATESTRESULTSFILENAME", "RESULTFILENAME", "SUMMARYFILENAME", "CSV_FILE_NAME", "NETLOGO_SETUP_FUNCTION","NETLOGO_RUN_FUNCTION", "ATESTRESULTFILENAME",
"EFASTRESULTFILENAME"))
check_methods_to_call[[list_index]] = check_text # TAKES ALL ARGS FIXED
else if(argNames[arg] %in% c("RUN_METRICS_EVERYSTEP","GRAPH_FLAG"))
check_methods_to_call[[list_index]] = check_boolean
else if(argNames[arg] == "LARGEDIFFINDICATOR")
check_methods_to_call[[list_index]] = check_double_value_in_range
else if(argNames[arg] == "TTEST_CONF_INT")
check_methods_to_call[[list_index]] = check_confidence_interval
else if(argNames[arg] == "OUTPUTFILECOLSTART")
check_methods_to_call[[list_index]] = check_column_ranges
# PMIN check not working with RoboSpartan
#else if(argNames[arg] == "PMIN")
# check_methods_to_call[[list_index]] = check_global_param_sampling_args
else if(argNames[arg] == "PARAMVALS") # This will also need some more thought once other approaches added
check_methods_to_call[[list_index]] = check_function_dependent_paramvals
# Same issue, error checking not working with RoboSpartan, algorithm removed
#else if(argNames[arg] == "ALGORITHM")
# check_methods_to_call[[list_index]] = check_lhs_algorithm
else if(argNames[arg] == "OUTPUT_TYPE")
check_methods_to_call[[list_index]] = check_graph_output_type
# To deal with AA_SIM_RESULTS_OBJECT, and OUTPUTFILECOLEND, which are checked by FILE and START respectively,
# and PMAX, BASELINE, PINC, that are checked in PMIN/PARAMVALS checks,we put in an ignore, and detect this later
# This needs to be done to keep the function list referenced to the argument names
else if(argNames[arg] %in% c("LHCSUMMARYFILENAME","CORCOEFFSOUTPUTFILE","FILEPATH","PARAMETERS","NUMSAMPLES","AA_SIM_RESULTS_OBJECT", "OUTPUTFILECOLEND", "PMAX","PINC","BASELINE","ALTFILENAME","OUTPUTMEASURES_TO_TTEST","AA_SIM_RESULTS_FILE","ALGORITHM","NUMCURVES","SPARTAN_PARAMETER_FILE","LHC_ALL_SIM_RESULTS_FILE"))
check_methods_to_call[[list_index]] = NULL
list_index = list_index + 1
# KA: No testing of nested filepaths in here - this may be worth re-adding: check_nested_filepaths(arguments$FILEPATH, arguments$PARAMETERS, preCheckSuccess)
# Also no testing of timepoints
# Need to test PARAMVALS for Netlogo LHC here, as well as test for installation of XML package
}
return(check_methods_to_call)
}
#' Executes the list of check functions compiled for the calling function
#'
#' This returns TRUE if all arguments pass, or FALSE when the first test fails
#'
#' @param check_methods_to_call List of check functions that should be called
#' @param input_arguments The user's input to a function
#' @param function_args The expected names of the arguments, provided by
#' calling function
#' @return Boolean stating whether the input checks pass or fail
execute_checks <- function(check_methods_to_call, input_arguments, function_args)
{
out<-NULL
for(check_method in 1:length(check_methods_to_call))
{
#out<-rbind(out,function_args[check_method])
#write_data_to_csv(out, "outlog.csv")
#print(function_args[check_method])
# Need to tailor some methods that cannot be called with the same two arguments, so check these first
if(identical(check_methods_to_call[[check_method]],check_double_value_in_range))
{
if(!check_double_value_in_range(input_arguments$LARGEDIFFINDICATOR, "LARGEDIFFINDICATOR",0,0.5)) # This will need changing if we use this method for any other arguments
return(FALSE)
}
else if(identical(check_methods_to_call[[check_method]],check_confidence_interval))
{
if(!check_confidence_interval(input_arguments$TTEST_CONF_INT, "TTEST_CONF_INT",0,1))
return(FALSE)
}
else if(identical(check_methods_to_call[[check_method]],check_consistency_result_type))
{
# As check_consistency_result type differs for each function, need to get the names of the R and file name arguments before calling
check_args <- get_file_and_object_argument_names(input_arguments)
# Now can call the function
if(!check_consistency_result_type(input_arguments, check_args$file, check_args$object))
return(FALSE)
}
else if(identical(check_methods_to_call[[check_method]],check_column_ranges))
{
# As this varies across functions, we need to get the correct file name to check
filepath <- get_correct_file_path_for_function(input_arguments)
# Now we can run the function
if(!check_column_ranges(input_arguments, filepath, input_arguments$RESULTFILENAME))
return(FALSE)
if(!is.null(eval(input_arguments$ALTFILENAME)))
if(!check_column_ranges(input_arguments, filepath, input_arguments$ALTFILENAME))
return(FALSE)
}
# Every other method needs no specific tailoring, just make sure we ignore any that were checked elsewhere
else if(!is.null(check_methods_to_call[[check_method]]))
{
if(!check_methods_to_call[[check_method]](input_arguments, function_args[check_method]))
{
return(FALSE)
}
}
}
return(TRUE)
}
#' Gets the correct file and R object argument names for the input checker
#'
#' check_consistency_result_type takes the argument name of a file or R
#' object, and this changes across functions. This takes the function name
#' and returns the correct argument names for passing to the function
#' @param input_arguments Input arguments object passed from the checked
#' function
#' @return List containg argument names for file and R object
get_file_and_object_argument_names <- function(input_arguments)
{
# First entry of input_arguments is the calling function, so we can adjust here as need be:
if(input_arguments[[1]]=="aa_summariseReplicateRuns")
return(list("file"="AA_SIM_RESULTS_FILE","object"="AA_SIM_RESULTS_OBJECT"))
else if(input_arguments[[1]]=="aa_SampleSizeSummary")
return(list("file"="ATESTRESULTS_FILE","object"="ATESTRESULTS_OBJECT"))
else if(input_arguments[[1]]=="aa_getATestResults")
return(list("file"="AA_SIM_RESULTS_FILE","object"="AA_SIM_RESULTS_OBJECT"))
}
#' Gets the correct filepath for the column range input checker
#'
#' check_column_ranges takes a filepath containing a sample results file,
#' and this changes across functions. This takes the function name
#' and returns the correct argument names for passing to the function
#' @param arguments Input arguments object passed from the checked
#' function
#' @return Filepath to the results file to check
get_correct_file_path_for_function <- function(arguments)
{
if(arguments[[1]] == "aa_summariseReplicateRuns")
return(file.path(eval(arguments$FILEPATH),eval(arguments$SAMPLESIZES)[1],"1","1"))
else if(arguments[[1]] == "oat_processParamSubsets")
return(paste(eval(arguments$FILEPATH),"/",eval(arguments$PARAMETERS)[1],"/",eval(arguments$PMIN)[1],"/1/",sep=""))
}
#' Call the correct paramvals check for the calling function, as netlogo & robustness differ
#' @param input_arguments List of the arguments provided to the called function
#' @param argument_name Null in this case, but keeps auto-called functions consistent
#' @return Boolean stating the status of the pre-execution checks
check_function_dependent_paramvals <- function(input_arguments, argument_name)
{
## Check for param vals also is dependent on the function called
if(toString(input_arguments[[1]]) %in% c("lhc_generate_lhc_sample_netlogo","efast_generate_sample_netlogo"))
return(check_netlogo_parameters_and_values(input_arguments, argument_name))
else if(toString(input_arguments[[1]]) %in% c("oat_parameter_sampling","oat_processParamSubsets","oat_csv_result_file_analysis"))
return(check_robustness_sampling_args(input_arguments, argument_name))
}
#' Checks the input values for global parameter sampling techniques
#' @param input_arguments List of the arguments provided to the called function
#' @param argument_name Null in this case, but keeps auto-called functions consistent
#' @return Boolean stating the status of the pre-execution checks
check_global_param_sampling_args <- function(input_arguments, argument_name)
{
# As PMIN also in robustness (yet this would fail if PMIN is null, we check the calling function)
# If this is not lhc or efast sampling, we simply return true. Robustness is taken care of in PARAMVALS check
if(toString(input_arguments[[1]]) %in% c("lhc_generate_lhc_sample","efast_generate_sample"))
return(check_parameters_and_ranges(input_arguments, argument_name))
else
return(TRUE)
}
#' Check the requested graph types are correct (PDF, PNG, TIFF, BMP)
#' @param input_arguments List of the arguments provided to the called function
#' @param argument_name Null in this case, but keeps auto-called functions consistent
#' @return Boolean stating the status of the pre-execution checks
check_graph_output_type <- function(input_arguments, argument_name)
{
outputs_requested <- eval(input_arguments$OUTPUT_TYPE)
for(out in 1:length(outputs_requested))
{
if(!outputs_requested[out] %in% c("PDF","PNG","TIFF","BMP"))
{
message("Graph types can only be PDF, PNG, TIFF, BMP")
return(FALSE)
}
}
return(TRUE)
}
#' Pre-execution checks to perform before the spartan robustness samplng
#' technique is executed. Checks all parameter input
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Null in this case, but keeps auto-called functions consistent
#' @return Boolean stating the status of the pre-execution checks
check_robustness_sampling_args <- function(arguments, argument_name)
{
check = FALSE
while(!check)
{
if(!check_robustness_range_or_values(arguments))
break;
# From the above test we know that the user has either specified PARAMVALS
# or PMIN,PMAX,INC choice - now we test dependent on that
if(is.null(eval(arguments$PARAMVALS)))
{
if(!check_robustness_parameter_and_ranges_lengths(arguments))
break
if(!check_numeric_list_values(arguments, "PMIN", "PMAX"))
break
if(!check_numeric_list_values(arguments, "PINC", "PMAX"))
break
if(!check_robustness_range_contains_baseline(arguments))
break
}
else
{
if(!check_paramvals_length_equals_parameter_length(arguments))
break
if(!check_robustness_paramvals_contains_baseline(arguments))
break
}
check = TRUE
}
return(check)
}
#' For robustness, check whether using PMIN/PMAX/PINC entry or PARAMVALS
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Name of the argument being checked.
#' @return Boolean stating the current status of the pre-execution checks,
#' or FALSE if this check fails
check_robustness_range_or_values <- function(arguments, argument_name)
{
if(is.null(eval(arguments$PARAMVALS)))
{
if(is.null(eval(arguments$PMIN)) | is.null(eval(arguments$PMAX)) | is.null(eval(arguments$PINC)))
{
message("You need to specify either PMIN,PMAX,and PINC, or the values to sample in PARAMVALS")
return(FALSE)
}
else
return(TRUE)
}
else
{
if(!is.null(eval(arguments$PMIN)) | !is.null(eval(arguments$PMAX)) | !is.null(eval(arguments$PINC)))
{
message("You need to specify either PMIN,PMAX,and PINC, or the values to sample in PARAMVALS")
return(FALSE)
}
else
return(TRUE)
}
}
#' Checks the netlogo parameters and values are formatted correctly
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Here for consistency in auto-function calling, but not used
#' @return Boolean stating the current status of the pre-execution checks,
#' or FALSE if this check fails
check_netlogo_parameters_and_values <- function(arguments, argument_name)
{
## KA: FOR THE MOMENT, THIS JUST CHECKS XML LIBRARY INSTALLED AND CALLS
## check_paramvals_length_equals_parameter_length: IDEALLY THIS THEN NEEDS
## TO CHECK THE VALUES
if(!check_package_installed("XML"))
return(FALSE)
else
return(check_paramvals_length_equals_parameter_length(arguments))
}
#' Where used in robustness analysis, check that the length of PARAMVALS equals
# the number of PARAMETERS
#' @param arguments List of the arguments provided to the called function
#' @return Boolean stating the current status of the pre-execution checks,
#' or FALSE if this check fails
check_paramvals_length_equals_parameter_length <- function(arguments)
{
tryCatch(
{
if(length(eval(arguments$PARAMETERS)) == length(eval(arguments$PARAMVALS)))
return(TRUE)
else
{
message("Number of entries in PARAMVALS should match the number of parameters")
message("Spartan Terminated")
return(FALSE)
}
},
error=function(cond) {
message("PARAMVALS or PARAMETERS has been declared incorrectly")
message("Spartan Function Terminated")
return(FALSE)
})
}
#' Checks that the parameter values specified in PARAMVALS contain the BASELINE
#'
#' The paramvals need to contain the BASELINE value else no behaviours can be
#' compared using the robustness analysis approach in Technique 2
#'
#' @param arguments List of the arguments provided to the called function
#' @return Boolean stating the current status of the pre-execution checks,
#' or FALSE if this check fails
check_robustness_paramvals_contains_baseline <- function(arguments)
{
tryCatch(
{
paramvalsCheck <- eval(arguments$PARAMVALS)
baselineCheck <- eval(arguments$BASELINE)
for(PARAM in 1:length(paramvalsCheck))
{
# PARAMVALS is a string separated list, so need to convert to numeric
numeric_paramVals <- lapply(strsplit(paramvalsCheck[PARAM], ','), as.numeric)[[1]]
if(!baselineCheck[PARAM] %in% numeric_paramVals)
{
message("PARAMVALS should contain the BASELINE value, else behaviours cannot be compared")
message("Spartan Terminated")
return(FALSE)
}
}
return(TRUE)
},
error=function(cond) {
message("Error in declaring BASELINE or PARAMVALS")
message("Spartan Function Terminated")
return(FALSE)
})
}
#' Checks that the range specified by PMIN and PMAX contains the BASELINE
#'
#' The paramvals need to contain the BASELINE value else no behaviours can be
#' compared using the robustness analysis approach in Technique 2
#'
#' @param arguments List of the arguments provided to the called function
#' @return Boolean stating the current status of the pre-execution checks,
#' or FALSE if this check fails
check_robustness_range_contains_baseline <- function(arguments)
{
tryCatch(
{
minCheck <- eval(arguments$PMIN)
baselineCheck <- eval(arguments$BASELINE)
incCheck <- eval(arguments$PINC)
maxCheck <- eval(arguments$PMAX)
for(PARAM in 1:length(baselineCheck))
{
# Generate the sequence
sample <- seq(minCheck[PARAM],maxCheck[PARAM],by=incCheck[PARAM])
# Trouble here as due to precision of doubles, we may not locate the baseline
# i.e. if 0.3 is there, and baseline is 0.3, the %in% check may still fail
# So convert to string using paste
# Does this contain the baseline:
if(!toString(baselineCheck[PARAM]) %in% paste(sample))
{
message("Range specified by PMIN and PMAX should contain the BASELINE value, else behaviours cannot be compared")
message("Spartan Terminated")
return(FALSE)
}
}
return(TRUE)
},
error=function(cond) {
message("Error in declaring BASELINE in range specified by PMIN, PMAX, and PINC")
message("Spartan Function Terminated")
return(FALSE)
})
}
#' Where used, checks that PARAMETERS, PMIN, PMAX, PINC, and BASELINE are all
#' the same length
#'
#' @param arguments List of the arguments provided to the called function
#' @return Boolean stating the current status of the pre-execution checks,
#' or FALSE if this check fails
check_robustness_parameter_and_ranges_lengths <- function(arguments)
{
tryCatch(
{
inputLengths <- c(length(eval(arguments$PARAMETERS)),
length(eval(arguments$BASELINE)),
length(eval(arguments$PMIN)),length(eval(arguments$PMAX)),
length(eval(arguments$PINC)))
# These should be all the same
if(all(inputLengths[1] == inputLengths))
return(TRUE)
else
{
message("Number of entries in PARAMETERS, BASELINE, PMIN, PMAX, and PINC should be equal")
message("Spartan Terminated")
return(FALSE)
}
},
error=function(cond) {
message("Error in declaring PARAMETERS, BASELINE, PMIN, PMAX, or PINC. Check all lengths are equal and all are numeric")
message("Spartan Function Terminated")
return(FALSE)
})
}
#' Pre-Check of the parameters and ranges specified for sampling parameter
#' space
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Here for consistency in auto-function calling, but not used
#' @return Boolean stating the current status of the pre-execution checks,
#' or FALSE if this check fails
check_parameters_and_ranges <- function(arguments, argument_name)
{
preCheckSuccess = check_lengths_parameters_ranges(arguments)
preCheckSuccess = check_numeric_list_values(arguments, "PMIN", "PMAX")
return(preCheckSuccess)
}
#' Check that the filepath of required data or output exists
#' @param arguments Input arguments
#' @param argument_name Name of the argument, as provided by function
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_filepath_exists <- function(arguments, argument_name)
{
tryCatch(
{
if(file.exists(eval(arguments[argument_name][[1]])))
return(TRUE)
else
{
message(paste("FILEPATH does not seem to exist:", eval(arguments[argument_name][[1]])))
message("Spartan Function Terminated")
return(FALSE)
}
},
error=function(cond) {
#print(cond)
message(paste("FILEPATH does not seem to exist"))
message("Spartan Function Terminated")
return(FALSE)
})
}
#' Check that the chosen lhc sampling algorithm is either normal or optimal.
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Argument name being checked. May be null, but here for consistency
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_lhs_algorithm <- function(arguments, argument_name)
{
tryCatch(
{
if(!check_package_installed("lhs"))
return(FALSE)
else
{
if(tolower(eval(arguments$ALGORITHM)) == "normal" | tolower(eval(arguments$ALGORITHM)) == "optimal")
return(TRUE)
else {
message("LHS Algorithm must be either 'normal' or 'optimal'. Terminated")
return(FALSE)
}
}
},
error=function(cond) {
message("LHS Algorithm must be either 'normal' or 'optimal'. Terminated")
return(FALSE)
})
}
#' Check that a required package has been installed
#' @param packageName Name of the package to check for
#' @return Boolean stating whether the package is installed or not
check_package_installed <- function(packageName)
{
tryCatch(
{
if(requireNamespace(packageName,quietly=TRUE))
return(TRUE)
else
message(paste("Looking for package ",packageName,", which is not installed or does not exist",sep=""))
return(FALSE)
},
error=function(cond) {
message(paste("Looking for package ",packageName,", which is not installed or does not exist",sep=""))
return(FALSE)
})
}
#' Check that the lengths of the parameters, minimum values, and maximum values, are equal
#' @param arguments List of the arguments provided to the called function
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_lengths_parameters_ranges <- function(arguments)
{
tryCatch(
{
minCheck <- as.numeric(get_argument_correct_case(arguments, "PMIN"))
maxCheck <- as.numeric(get_argument_correct_case(arguments, "PMAX"))
parameters <- get_argument_correct_case(arguments, "PARAMETERS")
if(length(parameters) == length(minCheck) & length(parameters) == length(maxCheck))
return(TRUE)
else {
message("Number of parameters must match the numbers of entries in PMIN and PMAX")
return(FALSE)
}
},
error=function(cond) {
message("Value error in PMIN or PMAX. Check these are numeric, and declared in capitals (not 'pmin' and 'pmax')")
message("Spartan Function Terminated")
# Choose a return value in case of error
return(FALSE)
},
# Warning may become apparent if the user enters a string as a number
warning=function(cond) {
message("Value error in PMIN or PMAX. Check these are numeric")
message("Spartan Function Terminated")
# Choose a return value in case of error
return(FALSE)
}
)
}
#' Check that two lists are numeric, and the values of one are less than the other
#' @param arguments List of the arguments provided to the called function
#' @param nameSmall Parameter name of the smaller list, for error reporting
#' @param nameLarge Parameter name of the larger list, for error reporting
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_numeric_list_values <- function(arguments, nameSmall, nameLarge)
{
#print(arguments)
tryCatch(
{
smallCheck <- get_argument_correct_case(arguments, nameSmall)
#print(smallCheck)
largeCheck <- get_argument_correct_case(arguments, nameLarge)
#print(largeCheck)
if(all(smallCheck < largeCheck) & is.numeric(smallCheck) & is.numeric(largeCheck))
return(TRUE)
else {
message(paste(nameSmall, " must be less than ", nameLarge, " for all parameters, both must be numeric, and declared in capitals: e.g. PMIN, PMAX, PINC",sep=""))
return(FALSE)
}
},
error=function(cond) {
message(paste("Value error in ",nameSmall, " or ", nameLarge, ". Check these are numeric, and declared in capitals: e.g. PMIN, PMAX, PINC",sep=""))
message("Spartan Function Terminated")
# Choose a return value in case of error
return(FALSE)
})
}
#' Tries upper and lower case names for input arguments
#'
#' The method checking relies on the user calling the variables the right name.
#' If they don't, an error is produced. This helper function checks they haven't
#' just used lower case arguments, in which case the lower case is checked
#'
#' @param arguments List of the arguments provided to the called function
#' @param argName Name of the argument to return
#' @return The evaluated input value of this argument
#'
get_argument_correct_case <- function(arguments, argName)
{
value = eval(arguments[argName][[1]])
if(is.null(value) & argName!="PMIN" & argName !="PMAX")
# Try raising argname to upper case, as it should have been specified
value = eval(arguments[tolower(argName)][[1]])
return(value)
}
#' Check that an argument that should be a positive integer has been specified correctly
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Name of the argument, for inclusion in the error message
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_argument_positive_int <- function(arguments,argument_name)
{
tryCatch(
{
# KA: Taken this out for the moment, given new check method
# Get the argument. We're going to force to upper case incase the user has specified lower
#arg <- get_argument_correct_case(arguments, argName)
arg <- eval(arguments[argument_name][[1]])
if(all.equal(arg, as.integer(arg)) & arg > 0)
return(TRUE)
else {
message(paste(argument_name, " must be a positive integer. Terminated",sep=""))
return(FALSE)
}
},
error=function(cond) {
message(paste(argument_name, " must be a positive integer. Terminated",sep=""))
message("Spartan Function Terminated")
# Choose a return value in case of error
return(FALSE)
},
warning=function(cond) {
message(paste(argument_name, " must be a positive integer. Terminated",sep=""))
message("Spartan Function Terminated")
# Choose a return value in case of error
return(FALSE)
})
}
#' Check that an argument that should be a boolean has been specified correctly
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Name of the argument, for inclusion in the error message
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_boolean <- function(arguments, argument_name)
{
tryCatch(
{
evaled_arg<-eval(arguments[argument_name][[1]])
if(tolower(evaled_arg)=="true" | tolower(evaled_arg)=="false")
return(TRUE)
else {
message(paste(argument_name," must be either true or false. Terminated", sep=""))
return(FALSE)
}
},
error=function(cond) {
message(paste(argument_name, " must be either true or false. Terminated",sep=""))
return(FALSE)
})
}
#' Check that an argument that should be a text label has been specified correctly
#'
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Name of the argument, for inclusion in the error message
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_text <-function(arguments, argument_name)
{
tryCatch(
{
argEvaled <- eval(arguments[argument_name][[1]])
if((typeof(argEvaled)=="character" | typeof(argEvaled) == "double") & length(argEvaled)>0)
return(TRUE)
else {
message(paste(argument_name, " must be either a text string or numeric. Error in declaration. Terminated",sep=""))
return(FALSE)
}
},
error=function(cond) {
message(paste(argument_name, " must be either a text string or numeric. Error in declaration. Terminated",sep=""))
return(FALSE)
})
}
#' Check that an arguments of a list that should be a text label has been specified correctly
#'
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Name of the argument, for inclusion in the error message
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_text_list <-function(arguments, argument_name)
{
tryCatch(
{
# Get the list
arg_list <- eval(arguments[argument_name][[1]])
for(i in 1:length(arg_list))
{
check = check_text(arg_list[i], argument_name)
if(!check)
{
message(paste("Error in declaration of ",argument_name,". Terminated",sep=""))
return(FALSE)
}
}
return(TRUE)
},
error=function(cond) {
message(paste("Error in declaration of ",argument_name,". Terminated",sep=""))
return(FALSE)
})
}
#' Check that a double argument is within a specified range
#'
#' @param argument Value of the argument to check
#' @param argument_name Name of the argument, for inclusion in the error message
#' @param range_min Minimum of the range
#' @param range_max Maximum of the range
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_double_value_in_range <- function(argument, argument_name, range_min, range_max)
{
tryCatch(
{
# Get the list
value <- eval(argument)
if(is.numeric(value) & (value >= range_min & value <= range_max))
return(TRUE)
else
{
message(paste(argument_name, " must be between ",range_min," and ", range_max,". Spartan terminated",sep=""))
return(FALSE)
}
},
error=function(cond) {
message(paste("Error: ", argument_name, " must be between ",range_min," and ", range_max,". Spartan terminated",sep=""))
return(FALSE)
})
}
#' Check that a confidence interval is within a specified range
#'
#' @param argument Value of the argument to check
#' @param argument_name Name of the argument, for inclusion in the error message
#' @param range_min Minimum of the range
#' @param range_max Maximum of the range
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_confidence_interval <- function(argument, argument_name, range_min, range_max)
{
tryCatch(
{
# Get the list
value <- eval(argument)
#h<-c(value, range_min,range_max)
if(is.numeric(value) & (value >= range_min & value <= range_max))
{
#h<-c(h,"TRUE")
return(TRUE)
}
else
{
#h<-c(h,"FALSE")
message(paste(argument_name, " must be between ",range_min," and ", range_max,". Spartan terminated",sep=""))
return(FALSE)
}
#write_data_to_csv(h,"Values.csv")
},
error=function(cond) {
message(paste("Error: ", argument_name, " must be between ",range_min," and ", range_max,". Spartan terminated",sep=""))
return(FALSE)
})
}
#' Check that all objects of a list are integers
#'
#' @param arguments List of the arguments provided to the called function
#' @param argument_name Name of the argument, for inclusion in the error message
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_list_all_integers <- function(arguments, argument_name)
{
tryCatch(
{
# Get the list
value_list <- eval(arguments[argument_name][[1]])
#print(value_list)
if(all(value_list == floor(value_list)) & all(value_list > 0))
return(TRUE)
else
{
message(paste(argument_name," must be a list of positive integers. Terminated",sep=""))
return(FALSE)
}
},
error=function(cond) {
#print(cond)
message(paste("Error in declaration of ",argument_name,". Spartan Terminated",sep=""))
return(FALSE)
})
}
#' Check that result filepaths under the root directory exist
#'
#' @param file_root Root directory of the data to analyse
#' @param sub_dirs List of the subdirectories that should be under the root
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_nested_filepaths <- function(file_root, sub_dirs)
{
tryCatch(
{
root <- eval(file_root)
sub_dir_list <- eval(sub_dirs)
not_exist <- c()
for(i in 1:length(sub_dir_list))
{
if(!file.exists(file.path(root,sub_dir_list[i])))
{
not_exist <- c(not_exist, sub_dir_list[i])
#message(paste("Sub-directory ",file.path(root,sub_dir_list[i])," does not exist. Spartan Terminated",sep=""))
#return(FALSE)
}
}
if(length(not_exist)>0)
{
message(paste("Sub-directories ",toString(not_exist), "do not exist. Spartan Terminated",sep=""))
return(FALSE)
}
else
{
return(TRUE)
}
},
error=function(cond) {
message(paste("Error in declaration of file paths to data to analyse. Spartan Terminated",sep=""))
return(FALSE)
})
}
#' Check that the user has declared either a file name or an R object
#' @param arguments List of the arguments provided to the called function
#' @param fileArg Name of the argument for which a file should be specified
#' @param rObjArg Name of the argument for which an R object should be specified
#' @return Boolean stating the current status of the pre-execution checks, or FALSE if this check fails
check_consistency_result_type <- function(arguments, fileArg, rObjArg)
{
tryCatch(
{
r_object <- eval(arguments[rObjArg][[1]])
file_name <- eval(arguments[fileArg][[1]])
filepath <- eval(arguments$FILEPATH)
# Must have specified either an R object or a file
if(is.null(r_object) & is.null(file_name))
{
message(paste("Error in declaring either ",fileArg," or ",rObjArg,". You must specify one. Spartan Terminated",sep=""))
return(FALSE)
}
else {
if(is.null(r_object))
{
# The user is specifying a results file name
# Can check this here
file_check <- check_text(arguments[fileArg][[1]], fileArg)
if(file_check)
{
if(is.null(eval(arguments$TIMEPOINTS)))
{
# Check the file exists
if(file.exists(file.path(filepath,file_name)))
return(TRUE)
else
{
message(paste("File ",file_name, " in argument ",fileArg, " does not exist in ",filepath,sep=""))
return(FALSE)
}
}
else
{
for(t in 1:length(eval(arguments$TIMEPOINTS)))
{
filename_full <- append_time_to_argument(
file_name, eval(arguments$TIMEPOINTS)[t],
check_file_extension(file_name))
if(!file.exists(file.path(filepath, filename_full)))
return(FALSE)
}
return(TRUE)
}
}
else
{
message(paste("Problem with declaration of argument ",fileArg,", ",file_name, ". Spartan Terminated",sep=""))
return(FALSE)
}
}
else
{
# Existence of R object will have been checked when evaluated earlier
return(TRUE)
}
}
},
error=function(cond) {
#print(cond)
message(paste("Error in declaring either ",fileArg," or ",rObjArg,". You must specify one. Spartan Terminated",sep=""))
return(FALSE)
})
}
#' Checks for the existence of a file
#' @param filepath Directory where the file should be
#' @param filename Name of the file
#' @return Boolean showing whether or not the file exists
check_file_exist <- function(filepath, filename)
{
tryCatch(
{
if(file.exists(file.path(filepath, filename)))
return(TRUE)
else
return(FALSE)
},
error=function(cond) {
# error printed in calling function
return(FALSE)
})
}
#' For aleatory analysis, checks the analysis start and end columns are sensible
#' @param arguments List of the arguments provided to the called function
#' @param filepath Evaluated filepath argument
#' @param resultfile Name of the result file of columns to check
#' @return Boolean stating the current status of the pre-execution checks,
#' or FALSE if this check fails
check_column_ranges <- function(arguments, filepath, resultfile)
{
# This opens the first result file and checks the number of columns.
# The assumption is made all others will be of the same structure
# So we need to get the first sample size
tryCatch(
{
if(is.null(eval(arguments$TIMEPOINTS)))
{
if(check_file_exist(filepath, eval(resultfile)))
{
# Load it and check number of columns
result<-read.csv(file.path(filepath, eval(resultfile)),header=T)
if(eval(arguments$OUTPUTFILECOLSTART) > 0 &
eval(arguments$OUTPUTFILECOLSTART) <= ncol(result) &
eval(arguments$OUTPUTFILECOLEND) > 0 &
eval(arguments$OUTPUTFILECOLEND) <= ncol(result) &
eval(arguments$OUTPUTFILECOLEND) >=
eval(arguments$OUTPUTFILECOLSTART)) {
return(TRUE)
} else {
message("Error in declaring either OUTPUTFILECOLSTART or OUTPUTFILECOLEND. Spartan Terminated")
return(FALSE)
}
}
else {
message(paste("Attempted to check OUTPUTFILECOLSTART and OUTPUTFILECOLEND in first result file, but file ",
paste(filepath,"/",resultfile,sep=""), " does not exist",sep=""))
return(FALSE)
}
}
else
{
# Timepoints not checked yet - must be added later
return(TRUE)
}
},
error=function(cond) {
#print(cond)
message("Error in declaring either OUTPUTFILECOLSTART or OUTPUTFILECOLEND. Spartan Terminated")
return(FALSE)
})
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.