https://github.com/cran/sparseFLMM
Raw File
Tip revision: b182e9a2447bc977ecd715351503848f37718038 authored by Jona Cederbaum on 19 June 2021, 08:10:02 UTC
version 0.4.1
Tip revision: b182e9a
get_cross_products.R
#####################################################################################################
# author: Jona Cederbaum and Fabian Scheipl
#####################################################################################################
# description: preparations for the covariance where only cross products of interest are constructed.
# uses functions in useful_functions.R.
#####################################################################################################

get_crossprods_fun <- function(y_tilde, curve_info, t, my_grid, d_grid, use_RI, I, J){

  ###################
  # initialize output
  ###################
  output <- list()

  if(!use_RI){
    ##################
    # for crossed fRIs
    res <- vector(mode = "list", length = I + J)
  }else{
    ###################################
    # for one fRI or independent curves
    res <- vector(mode = "list", length = I )
  }

  ##################################################
  # loop over subjects (first groupin_variable)
  # get all combinations on the same subjects
  # (same words or different words)
  # calls function make_crossprod_dt (defined below)
  ##################################################
  for(i in seq_len(I)){
    res[[i]] <- make_crossprod_dt(curve_info[subject_long == i, ], use_RI = use_RI)
  }

  if(!use_RI){
    ##################################################
    # loop over words (second grouping variable)
    # get all combinations on the same words
    # (same words or different subjects)
    # calls function make_crossprod_dt (defined below)
    ##################################################
    for(i in seq_len(J)){
      res[[I + i]] <- make_crossprod_dt(curve_info[word_long == i, ],
                                        preselection = "word", use_RI = use_RI)
    }
  }

  ret <- do.call(rbind, res)
  setkey(ret, id1, id2)

  #####################
  # take out id, y1, y2
  #####################
  set(ret, i = NULL, "id1", NULL)
  set(ret, i = NULL, "id2", NULL)

  set(ret, i = NULL, "y1", NULL)
  set(ret, i = NULL, "y2", NULL)

  ##################
  # rename t1 and t2
  ##################
  setnames(ret, old = c("t1", "t2"), new = c("row_t_bivariate", "col_t_bivariate"))

  #####################################
  # create indicators
  # same_word, same_subject, same_point
  #####################################
  if(!use_RI){
    ##################
    # for crossed fRIs
    output[["index"]] <- create_data_frame_bivariate_fun(index = ret)
  }else{
    ###################################
    # for one fRI or independent curves
    output[["index"]] <- create_data_frame_bivariate_RI_fun(index = ret)
  }

  #####################
  # construct grid data
  #####################
  grid_help <- create_grid_data_fun(my_grid = my_grid, d_grid = d_grid)

  output[["grid_row"]] <- grid_help$grid_row
  output[["grid_col"]] <- grid_help$grid_col

  output[["same_subject_grid"]] <- grid_help$same_subject
  if(!use_RI)
    output[["same_word_grid"]] <- grid_help$same_word
  output[["same_curve_grid"]] <- grid_help$same_curve_grid
  output[["same_point_grid"]] <- grid_help$same_point_grid

  rm(grid_help)

  ###############
  # return output
  ###############
  output
}

############################################################################################

make_crossprod_dt <- function(curve_info, preselection = c("none", "subject", "word"), use_RI){

  preselection <- match.arg(preselection)
  setkey(curve_info, id)

  ####################
  # take  combinations
  ####################
  combinations <- with(curve_info, CJ(id = id, id2 = id))

  if(!use_RI){
    tmp1 <- curve_info[combinations, list(id1 = id, subj1 = subject_long, word1 = word_long,
                                          rep1 = combi_long, n1 = n_long)]
  }else{
    tmp1 <- curve_info[combinations, list(id1 = id, subj1 = subject_long, n1 = n_long)]
  }

  if(!use_RI){
    tmp2 <- curve_info[combinations[, list(id = id2)],
                       list(id2 = id, subj2 = subject_long, word2 = word_long, rep2 = combi_long,
                            n2 = n_long)]
  }else{
    tmp2 <- curve_info[combinations[, list(id = id2)],
                       list(id2 = id, subj2 = subject_long, n2 = n_long)]
  }

  if(!use_RI){
    crosstable <- tmp1[, `:=`(id2 = tmp2$id2, subj2 = tmp2$subj2, word2 = tmp2$word2, rep2 = tmp2$rep2,
                              n2 = tmp2$n2)]
  }else{
    crosstable <- tmp1[, `:=`(id2 = tmp2$id2, subj2 = tmp2$subj2, n2 = tmp2$n2)]
  }

  ################################
  # remove irrelevant combinations
  ################################
  # NOTE: if preselection is "none" all subjects and words are used
  ## if preselection is "subject" only the subset of crosstable is used for which word1 != word2
  ## if preselection is "word" only  the subset of crosstable is used for which subj1 != subj2

  if(preselection == "none") {

  }
  if(preselection == "subject") {
    crosstable <- crosstable[word1 != word2, ]
  }
  if(preselection == "word") {
    crosstable <- crosstable[subj1 != subj2, ]
  }

  ###############################
  # add y and t to the data.table
  ###############################
  # once for id1 ordering and once for id2 ordering
  # leading to t1, t2, y1, y2 (when use_tri = TRUE also an indicator for t is added for both ordering)
  # NOTE: using the id key, we can directly assign the right values

  # add t1, y1, and (t_ind1)
  crosstable[, id := id1]
  setkey(crosstable, "id")
  crosstable <- crosstable[curve_info[, list(id, y_tilde, t)], ]
  setnames(crosstable, old = c("id1", "y_tilde", "t"),
           new = c("id1", "y1", "t1"))

  # add t2, y2, and (t_ind2)
  crosstable[, id := id2]
  setkey(crosstable, "id")
  crosstable <- crosstable[curve_info[, list(id, y_tilde, t)], ]
  if(!use_RI){
    setnames(crosstable, old = c("id", "y_tilde", "t", "subj1", "subj2", "word1", "word2", "rep1", "rep2"),
             new = c("id2", "y2", "t2", "row_subject_bivariate",
                   "col_subject_bivariate", "row_word_bivariate", "col_word_bivariate", "row_combi_bivariate", "col_combi_bivariate"))
  }else{
    setnames(crosstable, old = c("id", "y_tilde", "t", "subj1", "subj2"),#, "n1", "n2"),
             new = c("id2", "y2", "t2", "row_subject_bivariate",
                   "col_subject_bivariate"))#, "row_curve_bivariate",
                   #"col_curve_bivariate"))
    crosstable[, row_curve_bivariate := n1]
    crosstable[, col_curve_bivariate := n2]
  }

  #################################
  # redo sort (again sorted by id1)
  #################################
  setkey(crosstable, "id1")

  (crosstable[, cross_vec_bivariate := y1 * y2])

  ##############################
  # sort data table first by id1
  # and then by id2
  ##############################
  setkey(crosstable, id1, id2)

  ###############
  # return output
  ###############
  crosstable
}

back to top