Project: s41467-024-51844-2 | Function: partition_variance (r)

system: You are an expert R programmer implementing algorithms from scientific papers.
Complete the masked function based on the algorithm description.
Follow R best practices and maintain consistent code style.
Return **only** the complete R function code.

user: Complete this R function:

**DESCRIPTION:** Calculates the variance contribution of different site-combinations in protein fitness landscapes, partitioning total phenotypic variance across different order epistatic effects

**KEY TERMS:** {
  "site_combn": "site combinations for epistatic interactions",
  "e": "reference-free effects",
  "parse_effects_by_site_combn": "effect parsing by site combinations"
}

**CONTEXT CODE:**     
  }, integer(nrow(genotypes)))
  
  # glmnet does not accept a pattern matrix, so the entries are explicitly set
  # as 1.
  sparseMatrix(a, b, x = 1, dims = c(nrow(genotypes), sum(n_terms)))
}

# Sort reference-free effects by site-combination.
parse_effects_by_site_combn <- function(site_combn, e, as_array = FALSE) {
  
  # site_combn : list
  #   List of site-combinations being analyzed.
  # e : numeric vector
  #   Reference-free effects for the site-combinations.
  # as_array : logical
  #   If TRUE, state-combinations within each site-combination are arranged in
  #   an array. Otherwise, they are arranged in a vector.
  
  # Identifying reference-free effects for each site-combination.
  
  ord <- sapply(site_combn, length) # Order of each site-combination
  
  # Number of terms in each site-combination.
  n_terms <- sapply(site_combn, function(x) prod(q_list[x]))
  
  # Index of the last term of each site-combination.
  pos <- cumsum(c(0L, n_terms))
  
  # Sorting the effects for each site-combination into an element in a list.
  e_parsed <- lapply(1L:length(site_combn), function(i) e[(pos[i] + 1L):pos[i + 1L]])
  
  if(as_array) { 
    
    # Within a site-combination, state-combinations are ordered by the last
    # site moving fastest.
    
    for(i in which(ord > 1L)) {
      
      sites <- site_combn[[i]]
      qs <- q_list[sites] # Number of states in each site
      E <- array(e_parsed[[i]], rev(qs))
      e_parsed[[i]] <- aperm(E, length(sites):1L)
    }
  }
  
  e_parsed
}

# Calculate the fraction of variance due to each reference-free effect.
partition_variance <- function(site_combn, e, as_array = TRUE) {
  stop("Function implementation has been masked")
}


# Enforce the zero-mean property.
# Enforce the zero-mean property.
normalize_effects <- function(e, site_combn, genotypes) {
  stop("Function implementation has been masked")
}


# Custom link functions for use in glmnet.
custom_link <- function() {
  
  # To add more link functions, create a function analogous to 'glogit'
  # following the instructions therein. Then return a function call using the
  # if-else loop at the end.
  
  # The sigmoid link function.
  glogit <- function(L, R) {
    
    # L, R : numeric
    #   Lower bound and range of the sigmoid.
    #
    # In the formalism of generalized linear model, mu is the predicted expected
    # value of the response variable (phenotype), and eta is the
    # linear predictor (genetic score). They are related by
    #
    #   mu = linkinv(eta),
    #   eta = linkfun(mu).
    #
    # Note that what we call the sigmoid link function for incorporating
    # nonspecific epistasis is the inverse link function (linkinv) in the
    # formalism of generalized linear model.
    
    # Link function (inverse of the sigmoid).
    linkfun <- function(mu) {
      
      x <- (mu - L) / ((L + R) - mu)
      x[mu < L] <- 0
      x[mu > (L + R)] <- Inf
      log(x)
    }
    
    # Inverse link function (sigmoid).
    linkinv <- function(eta) L + R / (1 + exp(-eta))
    
    # Derivative of mu with respect to eta.
    mu.eta <- function(eta) R / ((1 + exp(-eta)) * (1 + exp(eta)))
    
    # Indicator for whether eta is in the domain of linkinv; this is always TRUE
    # for the sigmoid.
    valideta <- function(eta) TRUE
    
    # Creat an instance of class link-glm.
    structure(list(linkfun = linkfun, linkinv = linkinv, mu.eta = mu.eta,
                   valideta = valideta, name = 'glogit'),
              class = 'link-glm')
  }
  
  if(nonspec_type == 'sigmoid')
    glogit(nonspec_param[1L], nonspec_param[2L])
  else
    stop(paste("Link function '", nonspec_type, "' unavailable.", sep = ''))
}

# Transform genetic score by nonspecific epistasis.
apply_nonspecific_epistasis <- function(s, nonspec_param) {
  
  # s : numeric vector
  #   Genetic scores.
  # nonspec_param : numeric vector
  #   Nonspecific epistasis parameters to use.
  
  # Add more link functions in this if-else loop.
  if(nonspec_type == 'none')
    s
  else if(nonspec_type == 'sigmoid')
    nonspec_param[1L] + nonspec_param[2L] / (1 + exp(-s))
  else
    stop(paste("Link function '", nonspec_type, "' unavailable.", sep = '')) 
}

# Infer reference-free effects.
infer_model <- function(genotypes, y, site_combn, lambda = 0, norm_e = TRUE) {
  
  # genotypes : numeric matrix
  #   Genotype matrix.
  # y : numeric vector
  #   Phenotype vector.
  # site_combn : list
  #   Site-combinations to model.
  # lambda : numeric
  #   Lasso penalty.
  # norm_e : logical
  #   If TRUE, the zero-mean constraint is enforced on the returned model.
  #
  # Returns a list with the following elements.
  # nonspec_param : (numeric vector) The nonspecific epistasis parameters used


Complete the function implementation replacing "stop("Not implemented")".