R/create.DNcenters.R

In datanugget: Create, Optimize, and Refine Data Nuggets

# This function creates the centers of data nuggets(DN) from a random sample.
# It returns the dataframe with DN.num of DN centers.

# Function inputs
# RS: random sample of observations.
# delete.percent: proportion of data points to be deleted at each iteration.
# DN.num: final number of DNs to retain.
# dist.metric: pairwise distance measure (e.g., "euclidean" or "manhattan").
# make.pbs: logical; whether to show a progress bar while the function runs.


create.DNcenters = function(RS, 
                            delete.percent = .1, 
                            DN.num,
                            dist.metric = "euclidean", 
                            make.pbs = FALSE){ 
  
  
  ## ------------------------------- 
  ## Argument checks 
  ## ------------------------------- 
  
  # check RS 
  if (!any(class(RS) %in% c("matrix", "data.frame", "data.table"))) { 
    stop('RS must be of class "matrix", "data.frame", or "data.table"') 
  } 
  
  
  # check delete.percent 
  if (!is.numeric(delete.percent)) { 
    stop('delete.percent must be of class "numeric"') 
  } 
  
  
  # make sure delete.percent is between 0 and 1 
  if (delete.percent <= 0 | delete.percent >= 1){ 
    stop("delete.percent must be within (0,1)") 
  } 
  
  
  # check DN.num 
  if (!(class(DN.num) %in% c("numeric", "integer"))) { 
    stop('DN.num must be of class "numeric" or "integer"') 
  } 
  
  
  # check dist.metric 
  if (dist.metric != "euclidean" & dist.metric != "manhattan") { 
    stop('dist.metric must be "euclidean" or "manhattan"') 
  }
  
  
  # check make.pbs 
  if (!is.logical(make.pbs)) { 
    stop("make.pbs must be TRUE OR FALSE") 
  } 
  
  
  
  ## ---------------------------------- 
  ## Pre processing and Initialization 
  ## ---------------------------------- 
  
  
  # Convert RS to matrix
  RS.mat <- as.matrix(RS) 
  
  
  # check RS elements
  if (!is.numeric(RS.mat)) stop("RS must contain only numeric columns")
  
  
  # storage mode set to double
  storage.mode(RS.mat) <- "double"
  
  
  # number of observations
  n.obs <- nrow(RS.mat)
  
  
  # keeping track of the number of observations to keep
  keep <- seq_len(n.obs)
  
  
  # return original data if no of DNs >= no of rows.
  if (n.obs <= DN.num){
    
    warning("DN.num is greater than or equal to the number of rows. Returning original data")
    
    out <- as.data.frame(RS.mat)
    rownames(out) <- seq_len(n.obs)
    attr(out, "kept") <- keep
    
    return(out)
  }
  

  
  ## ------------------------- 
  ## Pairwise Distance Matrix 
  ## ------------------------- 
  
  
  # Compute the pairwise distance matrix
  DN.dist.matrix <- Rfast::Dist(RS.mat, method = dist.metric) 
  
  
  # eliminate the diagonals from becoming a closest neighbor choice 
  diag(DN.dist.matrix) <- max(DN.dist.matrix) + 1 
  
  
  # storing the remaining no of rows after removal until completion 
  tmp.num <- n.obs
  
  
  # check if user wants a progress bar 
  if (make.pbs){ 
    
    # initialize progress bar 
    pb <- txtProgressBar(min = 0, max = n.obs - DN.num)
    
    # close the progress bar upon exit
    on.exit(close(pb), add = TRUE)
    
    # initialize the value for the progress bar 
    for.prog <- 0 
    
  } 
  
  
  
  ## ------------------------- 
  ## Working Function 
  ## ------------------------- 
  
  
  # eliminate the desired number data points that are closest together 
  while (tmp.num > DN.num){ 
    
    
    # the number of sample points to delete 
    delete.num <- max(1, floor(tmp.num * delete.percent))
    delete.num <- min(delete.num, tmp.num - DN.num)
    
    
    # for each sample point, find points with the smallest pairwise distance and their index
    nn.dist <- Rfast::rowMins(DN.dist.matrix, value = TRUE)
    nn.index <- Rfast::rowMins(DN.dist.matrix, value = FALSE)
    
    
    # order the distances
    ord <- order(nn.dist)
    
    
    # for marking the removed points
    marked <- logical(tmp.num)
    
    
    # count the no of deleted points
    taken <- 0
    
    
    # delete one of the rows in each pair of smallest distances
    for (p in ord){
      
      # stop if already removed the no of points to be deleted
      if (taken >= delete.num) break
      
      # delete if not deleted already and the other pair element is not deleted
      if (!marked[nn.index[p]] && !marked[p]){
        
        marked[p] <- TRUE
        taken <- taken + 1
      }
    }
    
    # rerun if still the no of points to be deleted is not removed
    if (taken < delete.num){
      
      for (p in ord){
        
        # stop if already removed the no of points to be deleted
        if (taken >= delete.num) break
        
        # delete if not deleted already
        if (!marked[p]){
          
          marked[p] <- TRUE
          taken <- taken + 1
        } 
      }
    }
    
    
    # selected row indices for removal 
    delete.entries <- which(marked)
    
    
    # kept row indices
    keep <- keep[-delete.entries]
    
    
    # delete the selected rows from the distance matrix 
    DN.dist.matrix <- DN.dist.matrix[-delete.entries, -delete.entries, drop = FALSE] 
    
    
    tmp.num <- length(keep)
    
    # check if user wants a progress bar 
    if (make.pbs == TRUE){ 
      
      for.prog <- for.prog + length(delete.entries) 
      
      # update the progress bar 
      utils::setTxtProgressBar(pb, for.prog) 
    }
  }
  
  # return the DN centers
  out <- as.data.frame(RS.mat[keep, , drop = FALSE])
  rownames(out) <- seq_len(nrow(out))
  attr(out, "kept") <- keep
  return(out)
}