Merge pull request #8 from datashield/v6.1-dev

V6.1 dev

Author: alexwesterberg

NAMESPACE

@@ -29,6 +29,7 @@ export(ds.densityGrid)
 export(ds.dim)
 export(ds.exists)
 export(ds.exp)
+export(ds.getWGSR)
 export(ds.glm)
 export(ds.glmPredict)
 export(ds.glmSLMA)

R/ds.getWGSR.R

@@ -0,0 +1,220 @@
+#'
+#' @title Computes the WHO Growth Reference z-scores of anthropometric data 
+#' @description Calculate WHO Growth Reference z-score for a given anthropometric measurement
+#' This function is similar to R function \code{getWGSR} from the \code{zscorer} package.
+#' @details The function calls the server-side function \code{getWGSRDS} that computes the WHO 
+#' Growth Reference z-scores of anthropometric data for weight, height or length, MUAC (middle
+#' upper arm circumference), head circumference, sub-scapular skinfold and triceps skinfold.
+#' Note that the function might fail or return NAs when the variables are outside the ranges
+#' given in the WGS (WHO Child Growth Standards) reference (i.e. 45 to 120 cm for height and
+#' 0 to 60 months for age). It is up to the user to check the ranges and the units of their 
+#' data.
+#' @param sex the name of the binary variable that indicates the sex of the subject. This must
+#' be coded as 1 = male and 2 = female. If in your project the variable sex has different
+#' levels, you should recode the levels to 1 for males and 2 for females using the 
+#' \code{ds.recodeValues} DataSHIELD function before the use of the \code{ds.getWGSR}.
+#' @param firstPart Name of variable specifying:\cr
+#' Weight (kg) for BMI/A, W/A, W/H, or W/L\cr
+#' Head circumference (cm) for HC/A\cr
+#' Height (cm) for H/A\cr
+#' Length (cm) for L/A\cr
+#' MUAC (cm) for MUAC/A\cr
+#' Sub-scapular skinfold (mm) for SSF/A\cr
+#' Triceps skinfold (mm) for TSF/A\cr
+#' Give a quoted variable name as in (e.g.) "weight". Be careful with units (weight in kg;
+#' height, length, head circumference, and MUAC in cm; skinfolds in mm).
+#' @param secondPart Name of variable specifying:\cr
+#' Age (days) for H/A, HC/A, L/A, MUAC/A, SSF/A, or TSF/A\cr
+#' Height (cm) for BMI/A, or W/H\cr
+#' Length (cm) for W/L\cr
+#' Give a quoted variable name as in (e.g.) "age". Be careful with units (age in days;
+#' height and length in cm).
+#' @param index The index to be calculated and added to data. One of:\cr
+#' bfa BMI for age\cr
+#' hca Head circumference for age\cr
+#' hfa Height for age\cr
+#' lfa Length for age\cr
+#' mfa MUAC for age\cr
+#' ssa Sub-scapular skinfold for age\cr
+#' tsa Triceps skinfold for age\cr
+#' wfa Weight for age\cr
+#' wfh Weight for height\cr
+#' wfl Weight for length\cr
+#' Give a quoted index name as in (e.g.) "wfh".
+#' @param standing Variable specifying how stature was measured. If NA (default) then age (for "hfa"
+#' or "lfa") or height rules (for "wfh" or "wfl") will be applied. This must be coded as
+#' 1 = Standing; 2 = Supine; 3 = Unknown. Missing values will be recoded to 3 = Unknown. 
+#' Give a single value (e.g."1"). If no value is specified then height and age rules will be applied.
+#' @param thirdPart Name of variable specifying age (in days) for BMI/A. Give a quoted variable
+#' name as in (e.g.) "age". Be careful with units (age in days). If age is given in different units
+#' you should convert it in age in days using the \code{ds.make} DataSHIELD function before the use
+#' of the \code{ds.getWGSR}. For example if age is given in months then the transformation is given
+#' by the formula $age_days=age_months*(365.25/12)$. 
+#' @param newobj a character string that provides the name for the output variable 
+#' that is stored on the data servers. Defaults \code{getWGSR.newobj}. 
+#' @param datasources a list of \code{\link{DSConnection-class}} objects obtained after login. 
+#' If the \code{datasources} argument is not specified the default set of connections will be
+#' used: see \code{\link{datashield.connections_default}}.
+#' @return \code{ds.getWGSR} assigns a vector for each study that includes the z-scores for the
+#' specified index. The created vectors are stored in the servers.
+#' @author Demetris Avraam for DataSHIELD Development Team
+#' @export
+#' @examples
+#' \dontrun{
+#'
+#'   # Connecting to the Opal servers
+#' 
+#'   require('DSI')
+#'   require('DSOpal')
+#'   require('dsBaseClient')
+#' 
+#'   builder <- DSI::newDSLoginBuilder()
+#'   builder$append(server = "study1", 
+#'                  url = "http://192.168.56.100:8080/", 
+#'                  user = "administrator", password = "datashield_test&", 
+#'                  table = "ANTHRO.anthro1", driver = "OpalDriver")
+#'   builder$append(server = "study2", 
+#'                  url = "http://192.168.56.100:8080/", 
+#'                  user = "administrator", password = "datashield_test&", 
+#'                  table = "ANTHRO.anthro2", driver = "OpalDriver")
+#'   builder$append(server = "study3",
+#'                  url = "http://192.168.56.100:8080/", 
+#'                  user = "administrator", password = "datashield_test&", 
+#'                  table = "ANTHRO.anthro3", driver = "OpalDriver")
+#'                  
+#'   logindata <- builder$build()
+#'   
+#'   # Log onto the remote Opal training servers
+#'   connections <- DSI::datashield.login(logins = logindata, assign = TRUE, symbol = "D") 
+#'   
+#'   # Example 1: Generate the weight-for-height (wfh) index
+#'   ds.getWGSR(sex = "D$sex", firstPart = "D$weight", secondPart = "D$height",
+#'            index = "wfh", newobj = "wfh_index", datasources = connections)
+#'
+#'   # Example 2: Generate the BMI for age (bfa) index
+#'   ds.getWGSR(sex = "D$sex", firstPart = "D$weight", secondPart = "D$height",
+#'            index = "bfa", thirdPart = "D$age", newobj = "bfa_index", datasources = connections)
+#'
+#'   # clear the Datashield R sessions and logout
+#'   datashield.logout(connections) 
+#'
+#' }
+#'
+ds.getWGSR <- function(sex=NULL, firstPart=NULL, secondPart=NULL, index=NULL, standing=NA, thirdPart=NA, newobj=NULL, datasources=NULL){
+  
+  # look for DS connections
+  if(is.null(datasources)){
+    datasources <- datashield.connections_find()
+  }
+  
+  if(is.null(sex)){
+    stop("Please provide the column name of the 'sex' variable!", call.=FALSE)
+  }
+  
+  if(is.null(firstPart)){
+    stop("Please provide the column name of the 'firstPart' variable!", call.=FALSE)
+  }
+  
+  if(is.null(secondPart)){
+    stop("Please provide the column name of the 'secondPart' variable!", call.=FALSE)
+  }
+  
+  # if 'firstPart' or 'secondPart' are not numeric return an error message
+  typ.firstPart <- checkClass(datasources, firstPart)
+  typ.secondPart <- checkClass(datasources, secondPart)
+  if(!('numeric' %in% typ.firstPart)){
+    stop("The 'firstPart' variable must be a 'numeric' variable!", call.=FALSE)
+  }
+  if(!('numeric' %in% typ.secondPart)){
+    stop("The 'secondPart' variable must be a 'numeric' variable!", call.=FALSE)
+  }
+  
+  if(!(index %in% c("bfa", "hca", "hfa", "lfa", "mfa", "ssa", "tsa", "wfa", "wfh", "wfl"))){
+    stop("Please provide a correct abbreviation for the index!", call.=FALSE)
+  }
+  
+  # If 'thirdPart' (age) is missing for BMI-for-age return an error message
+  if(index == "bfa" & is.na(thirdPart)) {
+    stop("'thirdPart' variable should not be missing for index 'bfa'", call.=FALSE)
+  }
+  
+  # If 'thirdPart' (age) is not numeric for BMI-for-age return an error message
+  if(index == "bfa"){
+    typ.thirdPart <- checkClass(datasources, thirdPart)
+    if(!('numeric' %in% typ.firstPart)){
+      stop("The 'thirdPart' variable must be a 'numeric' variable!", call.=FALSE)
+    }  
+  }
+  
+  # If 'standing' is not a value either 1, 2, 3, or NA return an error message
+  if(!(standing %in% c(NA, 1, 2, 3))) {
+    stop("The 'standing' variable must be a numeric value either 1, 2, or 3!", call.=FALSE)
+  }
+  
+  # check newobj not actively declared as null
+  if(is.null(newobj)){
+    newobj <- "getWGSR.newobj"
+  }
+  
+  cally <- call("getWGSRDS", sex, firstPart, secondPart, index, standing, thirdPart)
+  DSI::datashield.assign(datasources, newobj, cally)
+  
+  #############################################################################################################
+  # DataSHIELD CLIENTSIDE MODULE: CHECK KEY DATA OBJECTS SUCCESSFULLY CREATED  
+  
+  # SET APPROPRIATE PARAMETERS FOR THIS PARTICULAR FUNCTION 
+  test.obj.name <- newobj	
+  
+  # CALL SEVERSIDE FUNCTION
+  calltext <- call("testObjExistsDS", test.obj.name)
+  object.info <- DSI::datashield.aggregate(datasources, calltext)
+  
+  # CHECK IN EACH SOURCE WHETHER OBJECT NAME EXISTS
+  # AND WHETHER OBJECT PHYSICALLY EXISTS WITH A NON-NULL CLASS
+  num.datasources <- length(object.info)
+  
+  obj.name.exists.in.all.sources <- TRUE
+  obj.non.null.in.all.sources <- TRUE
+  
+  for(j in 1:num.datasources){
+    if(!object.info[[j]]$test.obj.exists){
+      obj.name.exists.in.all.sources <- FALSE
+    }
+    if(is.null(object.info[[j]]$test.obj.class) || object.info[[j]]$test.obj.class=="ABSENT"){
+      obj.non.null.in.all.sources <- FALSE
+    }
+  }
+  
+  if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){
+    return.message <- paste0("A data object <", test.obj.name, "> has been created in all specified data sources")
+  }else{
+    return.message.1 <- paste0("Error: A valid data object <", test.obj.name, "> does NOT exist in ALL specified data sources")
+    return.message.2 <- paste0("It is either ABSENT and/or has no valid content/class,see return.info above")	
+    return.message.3 <-	paste0("Please use ds.ls() to identify where missing")
+    return.message <- list(return.message.1,return.message.2,return.message.3)
+  }
+  
+  calltext <- call("messageDS", test.obj.name)
+  studyside.message <- DSI::datashield.aggregate(datasources, calltext)
+  no.errors <- TRUE
+  for(nd in 1:num.datasources){
+    if(studyside.message[[nd]]!="ALL OK: there are no studysideMessage(s) on this datasource"){
+      no.errors <- FALSE
+    }
+  }
+  
+  if(no.errors){
+    validity.check <- paste0("<",test.obj.name, "> appears valid in all sources")
+    return(list(is.object.created=return.message,validity.check=validity.check))
+  }
+  
+  if(!no.errors){
+    validity.check <- paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:")
+    return(list(is.object.created=return.message,validity.check=validity.check,
+                studyside.messages=studyside.message))
+  }
+  
+  # END OF CHECK OBJECT CREATED CORECTLY MODULE	
+  #######################################################################################################
+
+}  

R/ds.glmPredict.R

@@ -229,13 +229,13 @@ if(obj.name.exists.in.all.sources && obj.non.null.in.all.sources){										 	#
 																											#
 	if(no.errors){																							#
 	validity.check<-paste0("<",test.obj.name, "> appears valid in all sources")							    #
-	print(list(is.object.created=return.message,validity.check=validity.check))						    #
+#	print(list(is.object.created=return.message,validity.check=validity.check))						    #
 	}																										#
 																											#
 if(!no.errors){																								#
 	validity.check<-paste0("<",test.obj.name,"> invalid in at least one source. See studyside.messages:")   #
-	print(list(is.object.created=return.message,validity.check=validity.check,					    		#
-	            studyside.messages=studyside.message))			                                            #
+#	print(list(is.object.created=return.message,validity.check=validity.check,					    		#
+#	            studyside.messages=studyside.message))			                                            #
 	}																										#
 																											#
 #END OF CHECK OBJECT CREATED CORECTLY MODULE															 	#

R/ds.recodeValues.R

@@ -7,8 +7,8 @@
 #' One particular use of
 #' \code{ds.recodeValues} is to convert NAs to an explicit value or vice-versa.
 #' 
-#' The argument \code{force.output.formata} can be specified in 3 ways: \cr
-#' (1) \code{force.output.formata = "numeric"} the output 
+#' The argument \code{force.output.format} can be specified in 3 ways: \cr
+#' (1) \code{force.output.format = "numeric"} the output 
 #' vector will be of type numeric and any non-numeric values in 
 #' \code{new.values.vector} will appear as \code{NaN} in the recoded vector.\cr
 #' (2) \code{force.output.format = "character"}  all values

README.md

@@ -32,4 +32,4 @@ Detailed instructions on how to install DataSHIELD are at https://www.datashield
 | obiba CRAN                   | Where you probably should install DataSHIELD from. |
 | releases                     | Stable releases. |
 | master branch                | Mostly in sync with the latest release, changes rarely. |
-| v6.0-dev branch (or similar) | Bleeding edge development. We make no claims that this branch is fully functional at any given time. |
+| v6.1-dev branch (or similar) | Bleeding edge development. We make no claims that this branch is fully functional at any given time. |

azure-pipelines.yml

@@ -29,6 +29,7 @@ variables:
   projectName: 'dsBaseClient'
   branchName:  $(Build.SourceBranchName)
   test_filter: '*'
+  _r_check_system_clock_: 0
 
 
 
@@ -400,6 +401,59 @@ jobs:
     condition: succeededOrFailed()
 
 
+    #####################################################################################
+    # Essentially run devtools::test() on the checked out code for bug reporting.
+    # The actual command is vary convoluted as it had to do some things
+    # which are not default behaviour: output the results to a JUnit xml file, not stop
+    # when a small number of errors have happened, run through the code coverage tool.
+    # TODO: Tidy up variable names - use timestamps here.
+  - bash: |
+
+      # junit reporter output is to test_results_bug.xml
+      sudo R -q -e '
+          library(testthat);
+          output_file <- file("test_console_output_bug.txt");
+          sink(output_file);
+          sink(output_file, type = "message");
+          junit_rep <- JunitReporter$new(file = "test_results_bug.xml");
+          progress_rep <- ProgressReporter$new(max_failures = 999999);
+          multi_rep <- MultiReporter$new(reporters = list(progress_rep, junit_rep));
+          testthat::test_package("$(projectName)", filter = "__bug-|datachk_bug-|smk_bug-|arg_bug-|disc_bug-|smk_expt_bug-|expt_bug-|math_bug-", reporter = multi_rep, stop_on_failure = FALSE)'
+
+      cat test_console_output_bug.txt
+
+      mv test_results_bug.xml $(Pipeline.Workspace)/logs
+
+    workingDirectory: $(Pipeline.Workspace)/dsBaseClient
+    displayName: 'Bug report output'
+    condition: succeededOrFailed()
+
+
+    #####################################################################################
+    # Parse the JUnit file to see if there are any errors/warnings. If there are then 
+    # echo them so finding bugs should be easier.
+    # This should run even if previous steps have failed.
+  - bash: |
+
+      # Strip out when error and failure = 0 and count the number of times it does not.
+      issue_count=$(sed 's/failures="0" errors="0"//' test_results_bug.xml | sed 's/errors="0" failures="0"//' | grep --count errors=)
+      echo "Number of testsuites with issues: "$issue_count
+      echo "Testsuites with issues:"
+      sed 's/failures="0" errors="0"//' test_results_bug.xml | sed 's/errors="0" failures="0"//' | grep errors= > issues.log
+      cat issues.log
+      no_issue_count=$(sed 's/failures="0" errors="0"//' test_results_bug.xml | sed 's/errors="0" failures="0"//' | grep -v --count errors=)
+      echo
+      echo "Number of testsuites with no issues: "$no_issue_count
+      echo "Testsuites with issues:"
+      sed 's/failures="0" errors="0"//' test_results_bug.xml | sed 's/errors="0" failures="0"//' | grep "<testsuite " | grep -v errors= > no_issues.log
+      cat no_issues.log
+      exit 0
+
+    workingDirectory: $(Pipeline.Workspace)/logs
+    displayName: 'Bug summary report output'
+    condition: succeededOrFailed()
+
+
     #####################################################################################
     # Output some important version numbers to file. This gets added to the testStatus 
     # commit so it can be parsed and used on the status table.