R/getHandSet.R

In rhoR: Rho for Inter Rater Reliability

###
#' @title Get Handset
#' @description This function is to get a handset of a set and calculate the kappa
#' @param set This is the set to take a handset of
#' @param handSetLength This is the length of the handset to take
#' @param handSetBaserate This is the minimum baserate to inflate the handset to
#' @param returnSet If TRUE, then return the handSet if FALSE, return the kappa of the handSet
#' 
#' @return The function returns the handSet if returnSet is TRUE or the kappa of the handSet if not
#' @export
###
getHandSet = function(set, handSetLength, handSetBaserate, returnSet=FALSE) {
  #positives is the minimum number of positive pairs in the first rater
  positives = ceiling(handSetLength * handSetBaserate);
  posInd = which(set[,1] == 1);

  if(positives > length(posInd)){stop("Not enough positives in first rater to inflate to this level")}
  #if there is an inflated baserate positives will be > 0, so if handSetBaserate > 0, positives > 0
  if (positives > 0) {
    #goes through and picks a set that fits the number of positives first then randomly samples from the rest
    #if the set created is not a valid set, then it reruns the process until a valid set is found
    positiveIndices = posInd[sample.int(length(posInd),size=positives,replace=FALSE)];
    others = set[!(1:nrow(set) %in% positiveIndices),];
    otherIndices = sample.int(nrow(others),size=(handSetLength - positives),replace=FALSE);
    this.set = rbind(set[positiveIndices,], others[otherIndices,]);
  } else if (positives == 0){
    #if there is no restriction on positives, then the set is generated by randomly sampling from the entire set
    #this.set=matrix(0,2,2);
    #while ((sum(this.set[,2]) == 0 | sum(this.set[,2]) == nrow(this.set))) {
      theseIndices = sample.int(nrow(set),size=handSetLength,replace=FALSE);
      this.set = set[theseIndices,];
    #}
  }

  #if return set is true return set rather than kappa
  if (returnSet) {
    this.set <- as.code.set(this.set);
    return(this.set);
  }

  #otherwise return the kappa of the set
  handSetKappa = calcKappa(this.set);
  
  return(handSetKappa);
}

###
#' @title Get Handset
#' @description This function is to get a handset of a set and calculate the kappa
#' 
#' @param full.ct This is the set to take a handset of
#' @param handSetLength This is the length of the handset to take
#' @param handSetBaserate This is the minimum baserate to inflate the handset to
#' @param as_kappa If FALSE then return the handSet, if TRUE (default) return the kappa of the handSet
#' 
#' @return The function returns the handSet if returnSet is TRUE or the kappa of the handSet if not
#' @export
###
getHandCT <- function(full.ct, handSetLength, handSetBaserate, as_kappa = TRUE) {
  positives <- ceiling(handSetLength * handSetBaserate)
  if (positives > sum(full.ct[1,])) {
    stop("Not enough positives in first rater to inflate to this level")
  }
  
  # positiveIndices <- sample_ct(full.ct[1,], positives)
  # 
  # other_ct <- full.ct
  # other_ct[1, ] <- other_ct[1, ] - positiveIndices
  # 
  # other_ct_vec <- as.vector(other_ct)
  # this_ct <- sample_ct(other_ct_vec,  handSetLength - positives)
  # this_ct[1, ] <- this_ct[1, ] + positiveIndices
  
  this_ct <- getHand_ct(ct = full.ct, handSetLength = handSetLength, handSetBaserate = handSetBaserate)

  if (!as_kappa) {
    this_ct <- as.contingency.table(this_ct);
    return(this_ct)
  } 

  return(kappa_ct(this_ct))
}

# sample_ct <- function(x, size) {
#   x_vec <- as.vector(x)
#   x_sampled <- matrix(rep(0, length(x)), ncol = length(x_vec) / 2)
#   for(i in seq(size)) {
#     s <- sample(seq(x_vec), 1, replace = F, prob = x_vec / sum(x_vec))
#     x_sampled[[s]] = x_sampled[[s]] + 1
#     x_vec[s] = x_vec[s] - 1
#   }
# 
#   return(x_sampled)
# }