R/label_helper.R

In adayim/cttab: Tables of Descriptive Statistics in word

# this entire method for compatibility with other packages where 
# "labelled' is single class rather than c("labelled", "numeric") etc.
#' @export
as.data.frame.labelled <- function(x, ..., nm = paste(deparse(substitute(x), width.cutoff = 500L)) ){
  if(length(class(x))>1){
    # because we can have labelled matrices or factors with variable label
    NextMethod("as.data.frame", ..., nm = nm, stringsAsFactors = FALSE)
    
  } else {
    # this branch for other packages where "labelled' is single class rather than c("labelled", "numeric") etc.
    
    as.data.frame.vector(x, ..., nm = nm, stringsAsFactors = FALSE)
  }
}



remove_incompatible_classes <- function(x){
  is.null(x) && return(x)
  INCOMPATIBLE_CLASSES = c("haven_labelled", "spss_labelled", "haven_labelled_spss", "vctrs_vctr")
  class(x) = setdiff(class(x), INCOMPATIBLE_CLASSES) 
  x
}

#' @export
c.labelled <- function(..., recursive = FALSE, use.names = TRUE)
{
  ### concatenate vectors of class 'labelled' and preserve labels
  vectors=list(...)
  vectors = lapply(vectors, remove_incompatible_classes)
  
  factors = vapply(vectors, FUN = inherits, FUN.VALUE = TRUE, "factor")
  if(any(factors)){
    y = c_labelled_factors(vectors)    
  } else {
    y = NextMethod()
  }
  dummy= lapply(vectors,var_lab)
  dummy=dummy[lengths(dummy)>0]
  if (length(dummy)>0)
    var_lab(y) <- dummy[[1]]
  
  dummy= lapply(vectors,val_lab)
  y = set_val_lab(y, do.call(combine_labels,dummy))
  y
}

extract_levels <- function(x){
  res = levels(x)
  if(is.null(res)) res = sort(unique(x)) 
  res
}

c_labelled_factors <- function(vectors){
  # to workaround strange dplyr behavior when
  # dplyr applies 'c' in the ungrouped mutate for unknown reasons
  if(length(vectors)==1) return(vectors[[1]])
  is_ordered = any(vapply(vectors, FUN = is.ordered, FUN.VALUE = TRUE))
  vectors = unlab(vectors)
  all_levels = lapply(vectors, extract_levels)
  all_levels = unique(unlist(all_levels, use.names = FALSE))
  res = unlist(lapply(vectors, as.character), use.names = FALSE)
  if(is_ordered){
    ordered(res, levels = all_levels)
  } else {
    factor(res, levels = all_levels) 
  }
}

#' @export
rep.labelled = function (x, ...){
  y= NextMethod()
  y = restore_attributes(y, x)
  y	
}

#' @export
'[.labelled' = function (x, ...){
  y = NextMethod()
  y = restore_attributes(y, x)
  y
}

#' @export
'[[.labelled' = function (x, ...){
  y = NextMethod()
  y = restore_attributes(y, x)
  y
}


# two assignment methods are needed to prevent state with inconsistent class and mode
# (such as 'numeric' in class but mode is character)
#' @export
'[<-.labelled' = function (x, ..., value){
  class(x) = setdiff(class(x), c("labelled", "labelled_spss"))
  y = NextMethod()
  class(y) = c("labelled", class(y))
  y
}

#' @export
'[[<-.labelled' <- function (x, ..., value){
  class(x) = setdiff(class(x), c("labelled", "labelled_spss"))
  y = NextMethod()
  class(y) = c("labelled", class(y))
  y
}


#' @export
unique.labelled <- function(x, incomparables = FALSE, fromLast = FALSE,
                           nmax = NA, ...){
  # TODO additional arguments with sensible names about labels support
  y = NextMethod()
  if(identical(nmax, 1)) {
    labels_support = 2
  } else {
    if(is.null(nmax)){
      labels_support = 0  
    } else {
      labels_support = getOption("expss.enable_value_labels_support", 1) 
    }
  }
  if(!identical(labels_support, 0)){
    if(identical(labels_support, 2)){
      y = unique(c(y, val_lab(x), use.names = FALSE), 
                 incomparables = incomparables, 
                 fromLast = fromLast, 
                 nmax = nmax, 
                 ...)
    }
    y = restore_attributes(y, x)
  }
  y
}


#' @export
#' @importFrom utils head str tail
str.labelled <- function(object, ...){
  cat("Class 'labelled'")
  str(unlab(object), ...)
  max_labels = 20
  if(!is.null(var_lab(object))) cat("   .. .. LABEL:",var_lab(object), "\n")
  vallab = val_lab(object)
  if(!is.null(vallab)){
    vallab = paste0(vallab, "=", names(vallab))
    n_labs = length(vallab)
    
    if(n_labs>max_labels) {
      max_labels  = floor(max_labels/2)
      if(max_labels<1) max_labels = 1
      head_vallab = paste(head(vallab, max_labels), collapse = ", ")
      tail_vallab = paste(tail(vallab, max_labels), collapse = ", ")
      vallab = paste0(head_vallab," ... ", tail_vallab)
    }  else {
      vallab = paste(vallab, collapse = ", ")
      
    } 
    cat("   .. .. VALUE LABELS",paste0("[1:",n_labs,"]:"),vallab, "\n")
  }
  invisible(NULL)
}



make_items_unique <- function(x, with_warning = NULL, sep = "_"){
  if(!is.character(x)) x = as.character(x)
  if(length(x)<2) return(x)
  if (anyDuplicated(x)){
    duplicates = duplicated(x)
    is.null(with_warning) || warning(paste0(with_warning, paste(paste0("'", x[duplicates], "'"), collapse = "', '")))
    while(anyDuplicated(x)){
      x[duplicates] = paste0(x[duplicates], "|")   
      duplicates = duplicated(x)
    }
    
  } 
  x
}


#' @export
restore_attributes <- function(new_var, old_var){
  # "measurement", "spss_measure", "spss.measure", "measure",
  preserved_attributes = c("label",  "format.spss", "measure",  
                           "display_width", "labels", "na_values", "na_range")
  # we bypass interfaces set_val_lab, set_var_lab to 
  # skip perfomance unfriendly sorting of labels
  for(each_attr in preserved_attributes){
    attr_value = attr(old_var, each_attr, exact = TRUE)
    if(!is.null(attr_value)){
      attr(new_var, each_attr) = attr_value
    }
  }
  # we use new_var class for such functions as `as.integer.labelled`
  class(new_var) = unique(c("labelled", class(new_var), use.names = FALSE))
  new_var
}