R/tapplyDS.R

In datashield/dsBase: DataSHIELD server site base functions

#' @title tapplyDS called by ds.tapply
#' @description Apply one of a selected range of functions to summarize an
#' outcome variable over one or more indexing factors and write the resultant
#' summary to the clientside
#' @details see details for \code{ds.tapply} function
#' @param X.name, the name of the variable to be summarized. Specified
#' via argument <X.name> of \code{ds.tapply} function
#' @param INDEX.names.transmit, the name of a single factor or a vector of names of factors to
#' index the variable to be summarized. Specified via argument <INDEX.names>
#' of \code{ds.tapply} function
#' @param FUN.name, the name of one of the allowable summarizing functions to be applied.
#' Specified via argument <FUN.name> of \code{ds.tapply} function.
#' @return an array of the summarized values created by the tapplyDS function. This array
#' is returned to the clientside. It has the same number of dimensions as INDEX.
#' @author Paul Burton, Demetris Avraam for DataSHIELD Development Team
#' @export
tapplyDS <- function(X.name, INDEX.names.transmit, FUN.name){

  # DataSHIELD MODULE: CAPTURE THE nfilter SETTINGS
  thr <- dsBase::listDisclosureSettingsDS()
  nfilter.tab <- as.numeric(thr$nfilter.tab)
  nfilter.subset <- as.numeric(thr$nfilter.subset)

  if(is.character(X.name)){
	  X <- eval(parse(text=X.name), envir = parent.frame())
	}else{
    studysideMessage <- "ERROR: X.name must be specified as a character string"
    stop(studysideMessage, call. = FALSE)
  }

  INDEX.factors <- unlist(strsplit(INDEX.names.transmit, split=","))

  num.factors <- length(INDEX.factors)

  # test that output vector and indexing factor all have the same length
  length.2.test <- length(X)

  length.test.vector <- rep(NA, num.factors)

  for(g in 1:num.factors){
    activation.text.0 <- paste0("INDEX.factors[",g,"]")
    active.factor.name <- eval(parse(text=activation.text.0))
    active.factor <- eval(parse(text=active.factor.name), envir = parent.frame())
    length.test.vector[g] <- length(active.factor)
  }
  
  for(h in 1:num.factors){
    if(length.2.test!=length.test.vector[h]){
      return.message <- "Error: the output variable and all indexing factors must be of equal length"
      stop(return.message, call. = FALSE)
    }  
  }

  # convert INDEX.names format from transmittable to actionable form (a list of vectors)
  INDEX.names.list <- paste0("list(",INDEX.names.transmit,")")
  INDEX <- eval(parse(text=INDEX.names.list), envir = parent.frame())

  # select complete cases on X and all INDEX factors only
  df <- as.data.frame(cbind(X, do.call(cbind, INDEX)))
  colnames(df) <- c(X.name, INDEX.factors)
  df.complete <- df[stats::complete.cases(df),]
   
  X.complete <- df.complete[,X.name]
  INDEX.complete <- df.complete[,c(INDEX.factors)]
   
  INDEX.complete.list <- list()
  if(num.factors > 1){
    for(i in 1:ncol(INDEX.complete)) {
      INDEX.complete.list[[i]] <- INDEX.complete[,i]
    }
    names(INDEX.complete.list) <- colnames(INDEX.complete) 
    INDEX <- INDEX.complete.list
  }else{
    INDEX <- list(INDEX.complete)
  }   
   
  ##################
  #disclosure traps#
  ##################
  N.count <- tapply(X.complete, INDEX, base::length)

  if(min(N.count) < nfilter.tab && min(N.count) > 0){
    return.message<-"ERROR: at least one group defined by INDEX has < nfilter.tab members. The output cannot therefore be returned to the clientside. But the function ds.tapply.assign may still be used to write the output to the data servers with no clientside return"
    stop(return.message, call. = FALSE)
  }

  #################
  #Valid functions#
  #################
  
  # N
  if(FUN.name=="N" || FUN.name=="length" || FUN.name=="Length" || FUN.name=="LENGTH"){
    
    # make output neat if up to two INDEX factors
    if(num.factors==1){
      factor1.levels <- levels(factor(INDEX[[1]]))
      factor1.level.names <- factor1.levels
      for(u in 1:length(factor1.levels)){
        factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
      }
      dimnames(N.count)[[1]] <- factor1.level.names
    }
    
    if(num.factors==2){
      factor1.levels <- levels(factor(INDEX[[1]]))
      factor1.level.names <- factor1.levels
      factor2.levels <- levels(factor(INDEX[[2]]))
      factor2.level.names <- factor2.levels
      for(u in 1:length(factor1.levels)){
        factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
      }
      for(v in 1:length(factor2.levels)){
        factor2.level.names[v] <- paste0(INDEX.factors[2], ".", factor2.levels[v])
      }
      dimnames(N.count)[[1]] <- factor1.level.names
      dimnames(N.count)[[2]] <- factor2.level.names
    }
    
    output <- list(N=N.count)
    return(output)
  }
  
  
  # MEAN
  if(FUN.name=="mean" || FUN.name=="Mean" || FUN.name=="MEAN"){
    
    Mean <- tapply(X.complete, INDEX, base::mean)
    
    # make output neat if up to two INDEX factors
    if(num.factors==1){
      factor1.levels <- levels(factor(INDEX[[1]]))
      factor1.level.names <- factor1.levels
      for(u in 1:length(factor1.levels)){
        factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
      }
      dimnames(Mean)[[1]] <- factor1.level.names
      dimnames(N.count)[[1]] <- factor1.level.names
    }
    
    if(num.factors==2){
      factor1.levels <- levels(factor(INDEX[[1]]))
      factor1.level.names <- factor1.levels
      factor2.levels <- levels(factor(INDEX[[2]]))
      factor2.level.names <- factor2.levels
      for(u in 1:length(factor1.levels)){
        factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
      }
      for(v in 1:length(factor2.levels)){
        factor2.level.names[v] <- paste0(INDEX.factors[2], ".", factor2.levels[v])
      }
      dimnames(Mean)[[1]] <- factor1.level.names
      dimnames(Mean)[[2]] <- factor2.level.names
      dimnames(N.count)[[1]] <- factor1.level.names
      dimnames(N.count)[[2]] <- factor2.level.names
    }
    
    output <- list(Mean=Mean, N=N.count)
    return(output)
  }
  
  # SD
  if(FUN.name=="sd" || FUN.name=="SD"){
    
    SD <- tapply(X.complete, INDEX, stats::sd)
    
    # make output neat if up to two INDEX factors
    if(num.factors==1){
      factor1.levels <- levels(factor(INDEX[[1]]))
      factor1.level.names <- factor1.levels
      for(u in 1:length(factor1.levels)){
        factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
      }
      dimnames(SD)[[1]] <- factor1.level.names
      dimnames(N.count)[[1]] <- factor1.level.names
    }
    
    if(num.factors==2){
      factor1.levels <- levels(factor(INDEX[[1]]))
      factor1.level.names <- factor1.levels
      factor2.levels <- levels(factor(INDEX[[2]]))
      factor2.level.names <- factor2.levels
      for(u in 1:length(factor1.levels)){
        factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
      }
      for(v in 1:length(factor2.levels)){
        factor2.level.names[v] <- paste0(INDEX.factors[2], ".", factor2.levels[v])
      }
      dimnames(SD)[[1]] <- factor1.level.names
      dimnames(SD)[[2]] <- factor2.level.names
      dimnames(N.count)[[1]] <- factor1.level.names
      dimnames(N.count)[[2]] <- factor2.level.names
    }
    
    output <- list(SD=SD, N=N.count)
    return(output)
  }
  
  # SUM
  if(FUN.name=="sum" || FUN.name=="Sum" || FUN.name=="SUM"){
    
    Sum <- tapply(X.complete, INDEX, base::sum)
    
    # make output neat if up to two INDEX factors
    if(num.factors==1){
      factor1.levels <- levels(factor(INDEX[[1]]))
      factor1.level.names <- factor1.levels
      for(u in 1:length(factor1.levels)){
        factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
      }
      dimnames(Sum)[[1]] <- factor1.level.names
      dimnames(N.count)[[1]] <- factor1.level.names
    }
    
    if(num.factors==2){
      factor1.levels <- levels(factor(INDEX[[1]]))
      factor1.level.names <- factor1.levels
      factor2.levels <- levels(factor(INDEX[[2]]))
      factor2.level.names <- factor2.levels
      for(u in 1:length(factor1.levels)){
        factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
      }
      for(v in 1:length(factor2.levels)){
        factor2.level.names[v] <- paste0(INDEX.factors[2], ".", factor2.levels[v])
      }
      dimnames(Sum)[[1]] <- factor1.level.names
      dimnames(Sum)[[2]] <- factor2.level.names
      dimnames(N.count)[[1]] <- factor1.level.names
      dimnames(N.count)[[2]] <- factor2.level.names
    }
    
    output <- list(Sum=Sum, N=N.count)
    return(output)
  }
  
  
  # QUANTILE
  if(FUN.name=="quantile" || FUN.name=="Quantile" || FUN.name=="QUANTILE"){
    
    if(num.factors > 1){
      studysideMessage <- "Quantile will only work with one indexing factor but you can combine several factors into one. e.g. two factors with f1 and f2 levels respectively can be combined into one with f1 x f2 levels"
      stop(studysideMessage, call. = FALSE)
    }
    probs.vector <- c(0.05,0.1,0.2,0.25,0.3,0.33,0.4,0.5,0.6,0.67,0.7,0.75,0.8,0.9,0.95)
    Quantile <- tapply(X.complete, INDEX, stats::quantile, probs=probs.vector)
    
    factor1.levels <- levels(factor(INDEX[[1]]))
    factor1.level.names <- factor1.levels
    for(u in 1:length(factor1.levels)){
      factor1.level.names[u] <- paste0(INDEX.factors[1], ".", factor1.levels[u])
    }
    dimnames(Quantile)[[1]] <- factor1.level.names
    
    return(Quantile)
  }
  
  return.message <- "Please specify a valid DataSHIELD tapply function e.g. FUN.name='mean' or FUN.name='sd'"
  return(return.message)
 
}
# AGGREGATE.FUNCTION
# tapplyDS