R/processor.R

In neural-structured-additive-learning/sparsedistreg: Fitting Deep Conditional Transformation Models

# sparses_layer = function(units, lasp, lasm, D, ...) {
#   python_path <- system.file("python", package = "sparsedistreg")
#   sparsedr <- reticulate::import_from_path("sparsedr", path = python_path)
#   sparsedr$SparseDR(num_outputs = units, lasp = lasp, lasm = lasm, D = D, ...)
# }

sparses_layer = function(units, lasp, lasm, D, ...) {
  python_path <- system.file("python", package = "sparsedistreg")
  sparsedr <- reticulate::import_from_path("sparsedr", path = python_path)
  sparsedr$SparseDRlayer(num_outputs = units, lasp = lasp, lasm = lasm, D = D, ...)
}

#' @export
sparses_processor <- function(term, data, output_dim, param_nr, controls){
  # only for univariate s-term
  
  name <- makelayername(term, param_nr)
  # term <- extract_pure_gam_part(term, FALSE)
  processor_name <- get_processor_name(term)
  gampart <- extract_pure_gam_part(term, FALSE)
  lasp <- suppressWarnings(extractval(gampart, "la"))
  
  output_dim <- as.integer(output_dim)

  # get sp and S
  sp_and_S <- get_gamdata(gampart, param_nr, controls$gamdata, what="sp_and_S")
  # check by-term and add penalty
  if(!is.null(controls$penalize_byterm))
    sp_and_S[[2]][[1]] <- sp_and_S[[2]][[1]] + controls$penalize_byterm * 
    diag(rep(1,ncol(sp_and_S[[2]][[1]]))) 
  # extract Xs
  # if(length(evaluated_gam_term)==1){
  #   thisX <- evaluated_gam_term[[1]]$X
  # }else{
  #   thisX <- do.call("cbind", lapply(evaluated_gam_term, "[[", "X"))
  # }
  # # get default Z matrix, which is possibly overwritten afterwards
  # Z <- diag(rep(1,ncol(thisX)))
  # # constraint
  # Z <- orthog_structured_smooths_Z(
  #   evaluated_gam_term[[1]]$X,
  #   matrix(rep(1,NROW(evaluated_gam_term[[1]]$X)), ncol=1)
  # )
  # sp_and_S[[2]][[1]] <- orthog_P(sp_and_S[[2]][[1]],Z)
  
  # coef function
  coef_fun <- function(weights)
  {
    weights <- lapply(weights, as.matrix)
    return(
      weights[[1]] * matrix(rep(weights[[2]], each=ncol(weights[[1]])), 
                            ncol=ncol(weights[[1]]), byrow = TRUE)
    )
  }
  
  # define layer  
  layer <- function(x, ...)
    return(sparses_layer(
      name = name,
      D = as.matrix(sp_and_S[[2]][[1]]),
      units = output_dim,
      lasp = controls$sp_scale(data) * lasp,
      lasm = controls$sp_scale(data) * sp_and_S[[1]][[1]])(x)
    )
  
  list(
    data_trafo = function() get_gamdata(gampart, param_nr, controls$gamdata, what="data_trafo")(),
    predict_trafo = function(newdata) 
      get_gamdata(gampart, param_nr, controls$gamdata, what="predict_trafo")(newdata),
    input_dim = get_gamdata(gampart, param_nr, controls$gamdata, what="input_dim"),
    layer = layer,
    coef = coef_fun,
    partial_effect = get_gamdata(gampart, param_nr, controls$gamdata, what="partial_effect"),
    plot_fun = function(self, weights, grid_length) 
      gam_plot_data(self, coef_fun(weights), grid_length),
    get_org_values = function() data[extractvar(term)],
    gamdata_nr = get_gamdata_reduced_nr(gampart, param_nr, controls$gamdata),
    gamdata_combined = FALSE
  )
}