Встраивание скрипта в for-l oop в R - PullRequest
Новая
       14

Встраивание скрипта в for-l oop в R

5 голосов
/ 17 апреля 2020

У меня есть датафрейм в R, который выглядит примерно так: 

 library(tibble)
 sample <- tribble(~subj, ~session,
            "A", 1,
            "A", 2, 
            "A", 3,
            "B", 1,
            "B", 2,
            "C", 1,
            "C", 2,
            "C", 3,
            "C", 4)

Как вы можете видеть из этого примера, есть несколько сеансов для каждого предмета, но не у всех предметов одинаковые количество сеансов. В моем реальном наборе данных 94 строки (5 предметов, от 15 до 20 различных сессий в каждой).

У меня есть другой скрипт, который берет мой основной набор данных (набор лингвистических c данных с подробным phoneti c функции для каждого предмета в каждом сеансе (почти 200 000 строк) и фильтры по предмету и сеансу для создания матрицы расстояний, показывающей евклидовы расстояния между различными словами. Я не могу воспроизвести его здесь по практическим соображениям, но создал пример сценария здесь: 

 library(tibble)
 data <- tribble(~subj, ~session, ~Target, ~S1C1_target,           # S1C1 = syllable 1, consonant 1
                 ~S1C1_T.Sonorant, ~S1C1_T.Consonantal,            # _T. = target consonant of S1C1
                 ~S1C1_T.Voice, ~S1C1_T.Nasal, ~S1C1_T.Degree,     # .Voice/.Nasal/etc are phonetic 
                                                                   # properties of the target word
            "A", 1, "electricity", "i", 0, 0, 0, 0, 0,
            "A", 1, "hectic", "h", 0.8, 0, 1, 0, 0,
            "A", 1, "pillow", "p", -1, 1, -1, 0, 0,
            "A", 2, "hello", "h", -0.5, 1, 0, -1, 0,
            "A", 2, "cup", "k", 0.8, 0, 1, 0, 0,
            "A", 2, "exam", "e", 0, 0, 0, 0, 0,
            "B", 1, "wug", "w", 0.8, 0, 1, 0, 0,
            "B", 1, "wug", "w", 0.8, 0, 1, 0, 0,
            "B", 1, "hug", "h", 0.8, 0, 1, 0, 0,
            "B", 2, "wug", "w", -0.5, 1, 0, -1, 0,
            "B", 2, "well", "w", 0.8, 0, 1, 0, 0,
            "B", 2, "what", "w", 0.8, 0, 1, 0, 0)

Я хочу начать с создания подмножества данных для каждого субъекта в каждом сеансе. Иногда у участника есть более одного токена одного и того же слова в Target, поэтому я также создаю среднее значение для повторных итераций: 

 matrixA1 <- data %>%                          # name the data after the subj and session name/number
   filter(subj == "A" & session == 1) %>%  
   dplyr::select(-subj, -session) %>%          # leave only the numeric values + `Target`
   group_by(Target) %>% 
   summarize_all(.funs = list(mean))           # Average across targets with more than one token



 ##### Calculate Euclidean distance between each phonetic property of each S1C1 target consonant

 ones <- rep(1,nrow(matrixA1))  # count repeated rows

 Son.mat.S1C1_T <- matrixA1$S1C1_T.Sonorant %*% t(ones) - ones %*% t(matrixA1$S1C1_T.Sonorant)
 rownames(Son.mat.S1C1_T) <- matrixA1$Target
 colnames(Son.mat.S1C1_T) <- matrixA1$Target
 colnames(Son.mat.S1C1_T) <- paste(colnames(Son.mat.S1C1_T), "Son.S1C1_T", sep = "_")

 Son.mat.S1C1_T <- Son.mat.S1C1_T^2

 Con.mat.S1C1_T <- matrixA1$S1C1_T.Consonantal %*% t(ones) - ones %*% t(matrixA1$S1C1_T.Consonantal)
 rownames(Con.mat.S1C1_T) <- matrixA1$Target
 colnames(Con.mat.S1C1_T) <- matrixA1$Target
 colnames(Con.mat.S1C1_T) <- paste(colnames(Con.mat.S1C1_T), "Con.S1C1_T", sep = "_")

 Con.mat.S1C1_T <- Con.mat.S1C1_T^2

 Voice.mat.S1C1_T <- matrixA1$S1C1_T.Voice %*% t(ones) - ones %*% t(matrixA1$S1C1_T.Voice)
 rownames(Voice.mat.S1C1_T) <- matrixA1$Target
 colnames(Voice.mat.S1C1_T) <- matrixA1$Target
 colnames(Voice.mat.S1C1_T) <- paste(colnames(Voice.mat.S1C1_T), "Voice.S1C1_T", sep = "_")

 Voice.mat.S1C1_T <- Voice.mat.S1C1_T^2

 Nasal.mat.S1C1_T <- matrixA1$S1C1_T.Nasal %*% t(ones) - ones %*% t(matrixA1$S1C1_T.Nasal)
 rownames(Nasal.mat.S1C1_T) <- matrixA1$Target
 colnames(Nasal.mat.S1C1_T) <- matrixA1$Target
 colnames(Nasal.mat.S1C1_T) <- paste(colnames(Nasal.mat.S1C1_T), "Nasal.S1C1_T", sep = "_")

 S1C1.1A <- Son.mat.S1C1_T +
   Con.mat.S1C1_T +
   Voice.mat.S1C1_T +
   Nasal.mat.S1C1_T

 colnames(S1C1.1A) = gsub("_Son.S1C1_T", "", colnames(S1C1.1A))

Это создает матрицу, которая выглядит примерно так: 

             electricity hectic pillow
 electricity    0.00      1.64   3.00
 hectic         1.64      0.00   8.24
 pillow         3.00      8.24   0.00

Как видите, этот код уже достаточно большой, а реальный код намного длиннее. Я знаю, что любой oop будет лучшим способом справиться с этим, но я не могу понять, как его запустить. Я хотел бы, чтобы это было так:

  1. Для каждой строки в sample создайте фрейм данных с subj и session в качестве идентификаторов в имени
  2. Для каждого из этих фреймов данных запустите приведенный выше скрипт, начиная с #####, чтобы создать матрицу для каждого предмета и каждого сеанса, как показано выше.

Для этого, я думаю, лучше всего можно встроить скрипт в for-l oop и указать, что он должен запускаться для каждой строки в sample.

Ответы [ 4 ]

3 голосов
/ 21 апреля 2020

Мне кажется, что вам не нужно ссылаться на ваш sample фрейм данных, потому что информация о комбинациях subj и session находится в вашем data. Если это не так, дайте мне знать. Иначе, вот мой подход.

Прежде всего, вместо ручной фильтрации данных для каждой комбинации subj и session, просто summarize ваших данных в одном go, после группировки данных согласно предметно-сессионным комбинациям. Перед этим присвойте каждому комбо id с group_indices: 

data_summ <- data %>%                          
  mutate(id = group_indices(., subj, session)) %>%
  group_by(subj, session, Target) %>% 
  summarize_all(.funs = list(mean))

Теперь вы можете работать со списком для прозрачности. Начните с разделения ваших обобщенных данных на список фреймов данных, по одному для каждой предметной сессии id: 

data_list <- data_summ %>%
  split(., f = .$id)

Теперь вы можете получить первый фрейм данных по data_list[[1]], второй по data_list[[2]] и так далее. Это позволяет вам l oop просматривать список и вычислять вашу матрицу для каждого элемента списка. Я упростил некоторые из вашего кода - например, вам не нужно называть каждую из четырех матриц (на основе S1C1_T.Consonantal, S1C1_T.Consonantal ...) заново. Я предлагаю вам сохранить все результаты в отдельном списке под названием mat_list. 

mat_list = list()

for (i in 1:length(data_list)) {

  element <- data_list[[i]]

  ones <- rep(1, nrow(element))

  sonorant_vec <- element$S1C1_T.Sonorant
  sonorant_mat <- (sonorant_vec %*% t(ones) - ones %*% t(sonorant_vec))^2

  consonantal_vec <- element$S1C1_T.Consonantal
  consonantal_mat <- (consonantal_vec %*% t(ones) - ones %*% t(consonantal_vec))^2

  voice_vec <- element$S1C1_T.Voice
  voice_mat <- (voice_vec %*% t(ones) - ones %*% t(voice_vec))^2

  nasal_vec <- element$S1C1_T.Nasal
  nasal_mat <- (nasal_vec %*% t(ones) - ones %*% t(nasal_vec))^2

  all_mat <- sonorant_mat + consonantal_mat + voice_mat + nasal_mat
  rownames(all_mat) <- element$Target
  colnames(all_mat) <- element$Target

  mat_list[[i]] <- all_mat
}

Et voilà: 

[[1]]
            electricity hectic pillow
electricity        0.00   1.64   3.00
hectic             1.64   0.00   8.24
pillow             3.00   8.24   0.00

[[2]]
       cup exam hello
cup   0.00 1.64  4.69
exam  1.64 0.00  2.25
hello 4.69 2.25  0.00

[[3]]
    hug wug
hug   0   0
wug   0   0

[[4]]
     well what  wug
well 0.00 0.00 4.69
what 0.00 0.00 4.69
wug  4.69 4.69 0.00

EDIT : если вы хотите избежать для l oop, вы можете поместить кусок внутрь l oop в функцию, а затем lapply до data_list: 

lapply(data_list, FUN = function(element) {

  ones <- rep(1, nrow(element))

  sonorant_vec <- element$S1C1_T.Sonorant
  sonorant_mat <- (sonorant_vec %*% t(ones) - ones %*% t(sonorant_vec))^2

  consonantal_vec <- element$S1C1_T.Consonantal
  consonantal_mat <- (consonantal_vec %*% t(ones) - ones %*% t(consonantal_vec))^2

  voice_vec <- element$S1C1_T.Voice
  voice_mat <- (voice_vec %*% t(ones) - ones %*% t(voice_vec))^2

  nasal_vec <- element$S1C1_T.Nasal
  nasal_mat <- (nasal_vec %*% t(ones) - ones %*% t(nasal_vec))^2

  all_mat <- sonorant_mat + consonantal_mat + voice_mat + nasal_mat
  rownames(all_mat) <- element$Target
  colnames(all_mat) <- element$Target

  return(all_mat)
})

РЕДАКТИРОВАТЬ 2

Чтобы назвать список элементы в соответствии с именами комбинаций субъект-сессия, вы можете сделать: 

data_summ <- data %>%                          
  group_by(subj, session, Target) %>% 
  summarize_all(.funs = list(mean)) %>%
  mutate(subj_session = paste(subj, session))

и затем разделить данные в соответствии с этим новым subj_session идентификатором: 

data_list <- data_summ %>%
  split(., f = .$subj_session)
2 голосов
/ 26 апреля 2020

Вот способ использования базы R. По сути, вы выполняете одинаковые операции для каждого столбца при разделении на subj и session. 

agg_data <-  aggregate(x = data[grep('Sonorant|Consonantal|Voice|Nasal', names(data))],
                       by =  data[c('subj', 'session', 'Target')],
                       FUN = mean)

by(data = agg_data[-which(names(agg_data) %in% c('subj', 'session'))],
   INDICES = agg_data[c('subj', 'session')],
   FUN = function (DF) {
     ones = rep(1, nrow(DF))
     mat = Reduce('+',
            lapply(DF[grep('Sonorant|Consonantal|Voice|Nasal', names(DF))],
                   function (x) (x %*% t(ones) - ones %*% t(x))^2)
            )
     colnames(mat) <- rownames(mat) <- DF[['Target']]
     mat
   }
)

Результаты - объект by: 

subj: A
session: 1
            electricity hectic pillow
electricity        0.00   1.64   3.00
hectic             1.64   0.00   8.24
pillow             3.00   8.24   0.00
--------------------------------------------------------------------------------------------------------------------------- 
subj: B
session: 1
    hug wug
hug   0   0
wug   0   0
--------------------------------------------------------------------------------------------------------------------------- 
subj: A
session: 2
       cup exam hello
cup   0.00 1.64  4.69
exam  1.64 0.00  2.25
hello 4.69 2.25  0.00
--------------------------------------------------------------------------------------------------------------------------- 
subj: B
session: 2
     well what  wug
well 0.00 0.00 4.69
what 0.00 0.00 4.69
wug  4.69 4.69 0.00

Наконец, вот метод, использующий . Так как вы создаете матрицу расстояний, эта версия использует dist(...), и мы заключаем матрицу расстояний в список: 

library(data.table)
dt = as.data.table(data)

done_dt = dt[, {tmp = .SD[, lapply(.SD, mean),
                by = Target,
                .SDcols = patterns('Sonorant|Consonantal|Voice|Nasal')]

      list(euc_dist = list(Reduce('+',
                                  lapply(tmp[, -1L, with = FALSE],
                                         function(x) dist(setNames(x, tmp[[1L]]))^2))))
      }
   , by = .(subj, session)]

И выходные данные: 

done_dt
     subj session       euc_dist
   <char>   <num>         <list>
1:      A       1 1.64,3.00,8.24
2:      A       2 4.69,2.25,1.64
3:      B       1              0
4:      B       2 4.69,4.69,0.00


done_dt[, euc_dist]
[[1]]
       electricity hectic
hectic        1.64       
pillow        3.00   8.24

[[2]]
     hello  cup
cup   4.69     
exam  2.25 1.64

[[3]]
    wug
hug   0

[[4]]
      wug well
well 4.69     
what 4.69 0.00
1 голос
/ 26 апреля 2020

Вот решение с использованием dplyr и для l oop: 

# Step1: summarization of data at Subject, session & Target level
masterDt <- data %>%                          
  group_by(subj, session, Target) %>% 
  summarize_all(.funs = list(mean)) %>%
  mutate(subj_session = paste(subj, session)) %>% 
  ungroup() 

#List of variables to be used in 
varList<- c("S1C1_T.Sonorant","S1C1_T.Consonantal","S1C1_T.Voice")

# Step2: Function to calculate distance

EquiDist = function (ds,varList,rowNameVar) {
  # ds: dataframe
  # varList: list of variables which 
  # rowNameVar : row names on which for the matrix

  ones = rep(1, nrow(ds))
  mat = Reduce('+',
               lapply(ds %>% dplyr::select(varList),
                      function (x) (x %*% t(ones) - ones %*% t(x))^2)
  )
  colnames(mat) <-ds[[rowNameVar]]
  rownames(mat) <- ds[[rowNameVar]]
  mat
}

#calculating distnace for all at one go
overallMat<- EquiDist(masterDt,varList = varList,rowNameVar = "Target")

# Step3: creating an Identifier for unique subject, session & Target level,

NamesGrp<- masterDt %>% 
  dplyr::select("subj_session","Target") %>% 
  dplyr::distinct() %>%
  dplyr::group_by(subj_session) %>%
  mutate(Identifier=paste0(Target, collapse = ",")) %>%
  dplyr::select(-Target) %>%
  dplyr::distinct()  %>% 
  dplyr::ungroup()

# matrix for each subject and each session

l=list()
temp<- matrix()
for (i in 1:nrow(NamesGrp)){
  List_Names=NamesGrp[["subj_session"]][i]
  listIdentifier=c(unlist(strsplit(NamesGrp[["Identifier"]][i],",")))
  temp= overallMat[listIdentifier,listIdentifier]
  l[[List_Names]]<-temp

}

#output can be accessed by names/ index of list l 
l$`A 1`
            electricity hectic pillow
electricity        0.00   1.64   3.00
hectic             1.64   0.00   8.24
pillow             3.00   8.24   0.00
1 голос
/ 20 апреля 2020

Чтобы ответить на ваш первый вопрос (вставьте скрипт в a для l oop), я бы предложил команду source(). Тогда вам просто нужна команда assign().

Такое ощущение, что ваш рабочий процесс выглядит следующим образом:

  1. Ваши первые два фрагмента кода.
  2. Все в вашем третьем коде чанк (matrixA1 <- и ниже).

  3. for(i in 1:nrow(sample)){ source(your_script.R) assign(x = paste0("df_", sample$subj[i], sample$session[i]), value = S1C1.1A) }

Вам необходимо изменить критерии фильтра. filter(subj == sample$subj[i] & session == sample$session[i]) должно работать.

Вам не нужен отдельный скрипт, хорошо иметь длинный l oop. Вы также можете сделать это функцией, если хотите. Но петли великолепны, и source() - отличная команда! Ключ здесь - команда assign().

...