R/poplinReduced-internals.R

In jaehyunjoo/poplin: LC/MS Metabolomics Data Processing Utilities

.get_poplinReduced_names <- function(...) {
  .get_poplinData_names(...)
}

.set_poplinReduced_names <- function(...) {
  .set_poplinData_names(...)
}

.get_poplinReduced_data_integer <- function(...) {
  .get_poplinData_data_integer(...)
}

.get_poplinReduced_data_character <- function(...) {
  .get_poplinData_data_character(...)
}

.get_poplinReduced_data_missing <- function(...) {
  .get_poplinData_data_missing(...)
}


.set_poplinReduced_data_integer <- function(x, type, value, get_slot,
                                            set_element_fun, funstr) {
  ## x <- updateObject(x)

  if (length(type) != 1L) {
    stop("attempt to replace more than one element")
  }

  if (!is.null(value)) {
    ## This dim assertion may be redundant as we pre-check dimnames
    if (!identical(nrow(value), ncol(x))) {
      stop("invalid 'value' in '",
           funstr, "(<", class(x), ">, type=\"numeric\") <- value':\n  ",
           "'value' should have number of rows equal to 'ncol(x)'")
    }
  }

  tmp <- get_slot(x)
  if (type > ncol(tmp)) {
    stop("'type' out of bounds in '", funstr,
         "(<", class(x), ">, type='numeric')")
  }

  tmp[[type]] <- value
  set_element_fun(x, tmp)

}


.set_poplinReduced_data_character <- function(x, type, value, get_slot,
                                              set_element_fun, funstr) {

  if (length(type) != 1L) {
    stop("attempt to replace more than one element")
  }

  if (!is.null(value)) {
    ## This dim assertion may be redundant as we pre-check dimnames
    if (!identical(nrow(value), ncol(x))) {
      stop("invalid 'value' in '",
           funstr, "(<", class(x), ">, type=\"character\") <- value':\n  ",
           "'value' should have number of rows equal to 'ncol(x)'")
    }
  }

  tmp <- get_slot(x)
  tmp[[type]] <- value
  set_element_fun(x, tmp)

}

.set_poplinReduced_data_missing <- function(...) {
  .set_poplinData_data_missing(...)
}


##' @importFrom methods as
##' @importFrom S4Vectors DataFrame I mcols mcols<- metadata metadata<-
.set_poplinReduced_datalist <- function(x, value, get_slot, set_element_fun,
                                        funstr, name_pattern) {
  ## x <- updateObject(x)

  if (identical(length(value), 0L)) {
    collected <- get_slot(x)[, 0] # DataFrame with 0 column
  } else {
    original <- value

    N_row <- vapply(value, nrow, 0L) # ensure integer of length 1
    if (!all(N_row == ncol(x))) {
      stop(
        "invalid 'value' in '", funstr, "(<", class(x), ">) <- value'\n",
        "each element of 'value' should have number of rows equal to 'ncol(x)'"
      )
    }

    names(value) <- .replace_empty_names(
      names(value), N = length(value), msg = "names(value)",
      name_pattern = name_pattern
    )

    collected <- do.call(
      DataFrame,
      c(lapply(value, I), list(row.names=NULL, check.names=FALSE))
    )

    ## Transfer metadata
    if (is(original, "Annotated")) {
      metadata(collected) <- metadata(original)
    }
    if (is(original, "Vector")) {
      mcols(collected) <- mcols(original)
    }
  }

  set_element_fun(x, collected)
}


.check_samplenames <- function(reference, incoming, fun) {
  if (!is.null(incoming)) {
    if (!(identical(ncol(reference), nrow(incoming)))) {
      stop("'value' should have number of rows equal to 'ncol(x)'")
    }
    samplenames_incoming <- rownames(incoming)
    samplenames_reference <- colnames(reference)
    if (!is.null(samplenames_incoming)) {
      if (!identical(samplenames_incoming, samplenames_reference)) {
        stop(
          "non-NULL 'rownames(value)' should be the same as 'colnames(x)' for '",
          fun
        )
      }
    } else {
      tryCatch({
        rownames(incoming) <- samplenames_reference
      }, error = function(e) {
        stop("'value' should have number of rows equal to 'ncol(x)'")
      })
    }
  }
  incoming
}