Akses nama indeks lapply di dalam MENYENANGKAN

Apakah ada cara untuk mendapatkan nama indeks daftar di fungsi lapply () saya?

n = names(mylist)
lapply(mylist, function(list.elem) { cat("What is the name of this list element?\n" })

Saya bertanya sebelumnya apakah mungkin untuk mempertahankan nama indeks di daftar kembali lapply () , tapi saya masih tidak tahu apakah ada cara mudah untuk mengambil setiap nama elemen di dalam fungsi kustom. Saya ingin menghindari memanggil nama-nama itu sendiri, saya lebih suka mendapatkan nama dalam parameter fungsi.

Sayangnya, lapplyhanya memberi Anda elemen vektor yang Anda lewati. Cara kerja yang biasa dilakukan adalah memberikannya nama atau indeks vektor, bukan vektor itu sendiri.

Tetapi perhatikan bahwa Anda selalu dapat menyampaikan argumen tambahan ke fungsi, jadi berikut ini berfungsi:

x <- list(a=11,b=12,c=13) # Changed to list to address concerns in commments
lapply(seq_along(x), function(y, n, i) { paste(n[[i]], y[[i]]) }, y=x, n=names(x))

Di sini saya menggunakan lapplylebih dari indeks x, tetapi juga lulus xdan nama x. Seperti yang Anda lihat, urutan argumen fungsi bisa berupa apa saja - lapplyakan melewati "elemen" (di sini indeks) ke argumen pertama yang tidak ditentukan di antara yang ekstra. Dalam hal ini, saya tentukan ydan n, jadi hanya ada yang itersisa ...

Yang menghasilkan sebagai berikut:

[[1]]
[1] "a 11"

[[2]]
[1] "b 12"

[[3]]
[1] "c 13"

UPDATE Contoh sederhana, hasil yang sama:

lapply(seq_along(x), function(i) paste(names(x)[[i]], x[[i]]))

Di sini fungsinya menggunakan variabel "global" xdan mengekstrak nama-nama dalam setiap panggilan.

Ini pada dasarnya menggunakan solusi yang sama seperti Tommy, tetapi dengan Map(), tidak perlu mengakses variabel global yang menyimpan nama-nama komponen daftar.

> x <- list(a=11, b=12, c=13)
> Map(function(x, i) paste(i, x), x, names(x))
$a
[1] "a 11"

$b
[1] "b 12"

$c
[1] "c 13

Atau, jika Anda mau mapply()

> mapply(function(x, i) paste(i, x), x, names(x))
     a      b      c 
"a 11" "b 12" "c 13"

UPDATE untuk R versi 3.2

Penafian: ini adalah trik hacky, dan mungkin berhenti bekerja di rilis berikutnya.

Anda bisa mendapatkan indeks menggunakan ini:

> lapply(list(a=10,b=20), function(x){parent.frame()$i[]})
$a
[1] 1

$b
[1] 2

Catatan: []diperlukan untuk ini untuk bekerja, karena itu menipu R untuk berpikir bahwa simbol i(yang berada dalam kerangka evaluasi lapply) dapat memiliki lebih banyak referensi, sehingga mengaktifkan duplikasi malas itu. Tanpa itu, R tidak akan menyimpan salinan terpisah dari i:

> lapply(list(a=10,b=20), function(x){parent.frame()$i})
$a
[1] 2

$b
[1] 2

Trik eksotis lainnya dapat digunakan, seperti function(x){parent.frame()$i+0}atau function(x){--parent.frame()$i}.

Dampak Kinerja

Apakah duplikasi paksa menyebabkan kehilangan kinerja? Iya! inilah tolok ukurnya:

> x <- as.list(seq_len(1e6))

> system.time( y <- lapply(x, function(x){parent.frame()$i[]}) )
user system elapsed
2.38 0.00 2.37
> system.time( y <- lapply(x, function(x){parent.frame()$i[]}) )
user system elapsed
2.45 0.00 2.45
> system.time( y <- lapply(x, function(x){parent.frame()$i[]}) )
user system elapsed
2.41 0.00 2.41
> y[[2]]
[1] 2

> system.time( y <- lapply(x, function(x){parent.frame()$i}) )
user system elapsed
1.92 0.00 1.93
> system.time( y <- lapply(x, function(x){parent.frame()$i}) )
user system elapsed
2.07 0.00 2.09
> system.time( y <- lapply(x, function(x){parent.frame()$i}) )
user system elapsed
1.89 0.00 1.89
> y[[2]]
[1] 1000000

Kesimpulan

Jawaban ini hanya menunjukkan bahwa Anda TIDAK boleh menggunakan ini ... Tidak hanya kode Anda akan lebih mudah dibaca jika Anda menemukan solusi lain seperti Tommy di atas, dan lebih kompatibel dengan rilis mendatang, Anda juga berisiko kehilangan optimisasi yang tim inti telah bekerja keras untuk melakukannya. mengembangkan!

Trik versi lama, tidak lagi berfungsi:

> lapply(list(a=10,b=10,c=10), function(x)substitute(x)[[3]])

Hasil:

$a
[1] 1

$b
[1] 2

$c
[1] 3

Penjelasan: lapplymembuat panggilan formulir FUN(X[[1L]], ...), FUN(X[[2L]], ...)dll. Jadi argumen yang dilewatinya adalah di X[[i]]mana iindeks saat ini dalam loop. Jika kita mendapatkan ini sebelum dievaluasi (yaitu, jika kita menggunakan substitute), kita mendapatkan ekspresi yang tidak dievaluasi X[[i]]. Ini adalah panggilan untuk [[berfungsi, dengan argumen X(simbol) dan i(bilangan bulat). Jadi substitute(x)[[3]]mengembalikan integer ini dengan tepat.

Memiliki indeks, Anda dapat mengakses nama-nama sepele, jika Anda menyimpannya terlebih dahulu seperti ini:

L <- list(a=10,b=10,c=10)
n <- names(L)
lapply(L, function(x)n[substitute(x)[[3]]])

Hasil:

$a
[1] "a"

$b
[1] "b"

$c
[1] "c"

Atau gunakan trik kedua ini: :-)

lapply(list(a=10,b=10,c=10), function(x)names(eval(sys.call(1)[[2]]))[substitute(x)[[3]]])

(hasilnya sama).

Penjelasan 2: sys.call(1)kembali lapply(...), jadi itulah sys.call(1)[[2]]ekspresi yang digunakan sebagai argumen daftar lapply. Melewati ini untuk evalmenciptakan objek yang sah itunames dapat mengakses. Tricky, tetapi berhasil.

Bonus: cara kedua untuk mendapatkan nama:

lapply(list(a=10,b=10,c=10), function(x)eval.parent(quote(names(X)))[substitute(x)[[3]]])

Perhatikan bahwa itu Xadalah objek yang valid dalam kerangka induk dari FUN, dan referensi argumen daftar lapply, sehingga kita bisa mendapatkannya eval.parent.

Saya sering mengalami masalah yang sama ... Saya mulai menggunakan cara lain ... Daripada menggunakan lapply, saya sudah mulai menggunakanmapply

n = names(mylist)
mapply(function(list.elem, names) { }, list.elem = mylist, names = n)

Anda dapat mencoba menggunakan imap()dari purrrpaket.

Dari dokumentasi:

imap (x, ...) adalah kependekan dari map2 (x, nama (x), ...) jika x memiliki nama, atau map2 (x, seq_along (x), ...) jika tidak.

Jadi, Anda bisa menggunakannya seperti itu:

library(purrr)
myList <- list(a=11,b=12,c=13) 
imap(myList, function(x, y) paste(x, y))

Yang akan memberi Anda hasil berikut:

$a
[1] "11 a"

$b
[1] "12 b"

$c
[1] "13 c"

Ulangi saja namanya.

sapply(names(mylist), function(n) { 
    doSomething(mylist[[n]])
    cat(n, '\n')
}

Jawaban Tommy berlaku untuk vektor bernama tetapi saya mendapat ide Anda tertarik pada daftar. Dan sepertinya dia melakukan end-around karena dia merujuk "x" dari lingkungan panggilan. Fungsi ini hanya menggunakan parameter yang diteruskan ke fungsi dan karenanya tidak membuat asumsi tentang nama objek yang diteruskan:

x <- list(a=11,b=12,c=13)
lapply(x, function(z) { attributes(deparse(substitute(z)))$names  } )
#--------
$a
NULL

$b
NULL

$c
NULL
#--------
 names( lapply(x, function(z) { attributes(deparse(substitute(z)))$names  } ))
#[1] "a" "b" "c"
 what_is_my_name <- function(ZZZ) return(deparse(substitute(ZZZ)))
 what_is_my_name(X)
#[1] "X"
what_is_my_name(ZZZ=this)
#[1] "this"
 exists("this")
#[1] FALSE

Jawaban saya berjalan ke arah yang sama dengan Tommy dan caracals, tetapi menghindari harus menyimpan daftar sebagai objek tambahan.

lapply(seq(3), function(i, y=list(a=14,b=15,c=16)) { paste(names(y)[[i]], y[[i]]) })

Hasil:

[[1]]
[1] "a 14"

[[2]]
[1] "b 15"

[[3]]
[1] "c 16"

Ini memberikan daftar sebagai argumen bernama untuk MENYENANGKAN (bukan untuk menjilat). lapply hanya perlu beralih pada elemen-elemen dari daftar (hati-hati untuk mengubah argumen pertama ini menjadi lapply ketika mengubah panjang daftar).

Catatan: Memberikan daftar secara langsung ke lapply sebagai argumen tambahan juga berfungsi:

lapply(seq(3), function(i, y) { paste(names(y)[[i]], y[[i]]) }, y=list(a=14,b=15,c=16))

@Caracals dan @Tommy adalah solusi yang baik dan ini adalah contoh termasuk list´s dan data.frame´s.
radalah a listdari list´s dan data.frame´s ( dput(r[[1]]pada akhirnya).

names(r)
[1] "todos"  "random"
r[[1]][1]
$F0
$F0$rst1
   algo  rst  prec  rorac prPo pos
1  Mean 56.4 0.450 25.872 91.2 239
6  gbm1 41.8 0.438 22.595 77.4 239
4  GAM2 37.2 0.512 43.256 50.0 172
7  gbm2 36.8 0.422 18.039 85.4 239
11 ran2 35.0 0.442 23.810 61.5 239
2  nai1 29.8 0.544 52.281 33.1 172
5  GAM3 28.8 0.403 12.743 94.6 239
3  GAM1 21.8 0.405 13.374 68.2 239
10 ran1 19.4 0.406 13.566 59.8 239
9  svm2 14.0 0.385  7.692 76.2 239
8  svm1  0.8 0.359  0.471 71.1 239

$F0$rst5
   algo  rst  prec  rorac prPo pos
1  Mean 52.4 0.441 23.604 92.9 239
7  gbm2 46.4 0.440 23.200 83.7 239
6  gbm1 31.2 0.416 16.421 79.5 239
5  GAM3 28.8 0.403 12.743 94.6 239
4  GAM2 28.2 0.481 34.815 47.1 172
11 ran2 26.6 0.422 18.095 61.5 239
2  nai1 23.6 0.519 45.385 30.2 172
3  GAM1 20.6 0.398 11.381 75.7 239
9  svm2 14.4 0.386  8.182 73.6 239
10 ran1 14.0 0.390  9.091 64.4 239
8  svm1  6.2 0.370  3.584 72.4 239

Tujuannya adalah untuk unlistsemua daftar, menempatkan urutan listnama ’sebagai kolom untuk mengidentifikasi kasus.

r=unlist(unlist(r,F),F)
names(r)
[1] "todos.F0.rst1"  "todos.F0.rst5"  "todos.T0.rst1"  "todos.T0.rst5"  "random.F0.rst1" "random.F0.rst5"
[7] "random.T0.rst1" "random.T0.rst5"

Batalkan daftar tetapi bukan data.frame´s.

ra=Reduce(rbind,Map(function(x,y) cbind(case=x,y),names(r),r))

Mapmenempatkan urutan nama sebagai kolom. Reducebergabunglah dengan semua data.frame.

head(ra)
            case algo  rst  prec  rorac prPo pos
1  todos.F0.rst1 Mean 56.4 0.450 25.872 91.2 239
6  todos.F0.rst1 gbm1 41.8 0.438 22.595 77.4 239
4  todos.F0.rst1 GAM2 37.2 0.512 43.256 50.0 172
7  todos.F0.rst1 gbm2 36.8 0.422 18.039 85.4 239
11 todos.F0.rst1 ran2 35.0 0.442 23.810 61.5 239
2  todos.F0.rst1 nai1 29.8 0.544 52.281 33.1 172

PS r[[1]]:

    structure(list(F0 = structure(list(rst1 = structure(list(algo = c("Mean", 
    "gbm1", "GAM2", "gbm2", "ran2", "nai1", "GAM3", "GAM1", "ran1", 
    "svm2", "svm1"), rst = c(56.4, 41.8, 37.2, 36.8, 35, 29.8, 28.8, 
    21.8, 19.4, 14, 0.8), prec = c(0.45, 0.438, 0.512, 0.422, 0.442, 
    0.544, 0.403, 0.405, 0.406, 0.385, 0.359), rorac = c(25.872, 
    22.595, 43.256, 18.039, 23.81, 52.281, 12.743, 13.374, 13.566, 
    7.692, 0.471), prPo = c(91.2, 77.4, 50, 85.4, 61.5, 33.1, 94.6, 
    68.2, 59.8, 76.2, 71.1), pos = c(239L, 239L, 172L, 239L, 239L, 
    172L, 239L, 239L, 239L, 239L, 239L)), .Names = c("algo", "rst", 
    "prec", "rorac", "prPo", "pos"), row.names = c(1L, 6L, 4L, 7L, 
    11L, 2L, 5L, 3L, 10L, 9L, 8L), class = "data.frame"), rst5 = structure(list(
        algo = c("Mean", "gbm2", "gbm1", "GAM3", "GAM2", "ran2", 
        "nai1", "GAM1", "svm2", "ran1", "svm1"), rst = c(52.4, 46.4, 
        31.2, 28.8, 28.2, 26.6, 23.6, 20.6, 14.4, 14, 6.2), prec = c(0.441, 
        0.44, 0.416, 0.403, 0.481, 0.422, 0.519, 0.398, 0.386, 0.39, 
        0.37), rorac = c(23.604, 23.2, 16.421, 12.743, 34.815, 18.095, 
        45.385, 11.381, 8.182, 9.091, 3.584), prPo = c(92.9, 83.7, 
        79.5, 94.6, 47.1, 61.5, 30.2, 75.7, 73.6, 64.4, 72.4), pos = c(239L, 
        239L, 239L, 239L, 172L, 239L, 172L, 239L, 239L, 239L, 239L
        )), .Names = c("algo", "rst", "prec", "rorac", "prPo", "pos"
    ), row.names = c(1L, 7L, 6L, 5L, 4L, 11L, 2L, 3L, 9L, 10L, 8L
    ), class = "data.frame")), .Names = c("rst1", "rst5")), T0 = structure(list(
        rst1 = structure(list(algo = c("Mean", "ran1", "GAM1", "GAM2", 
        "gbm1", "svm1", "nai1", "gbm2", "svm2", "ran2"), rst = c(22.6, 
        19.4, 13.6, 10.2, 9.6, 8, 5.6, 3.4, -0.4, -0.6), prec = c(0.478, 
        0.452, 0.5, 0.421, 0.423, 0.833, 0.429, 0.373, 0.355, 0.356
        ), rorac = c(33.731, 26.575, 40, 17.895, 18.462, 133.333, 
        20, 4.533, -0.526, -0.368), prPo = c(34.4, 52.1, 24.3, 40.7, 
        37.1, 3.1, 14.4, 53.6, 54.3, 116.4), pos = c(195L, 140L, 
        140L, 140L, 140L, 195L, 195L, 140L, 140L, 140L)), .Names = c("algo", 
        "rst", "prec", "rorac", "prPo", "pos"), row.names = c(1L, 
        9L, 3L, 4L, 5L, 7L, 2L, 6L, 8L, 10L), class = "data.frame"), 
        rst5 = structure(list(algo = c("gbm1", "ran1", "Mean", "GAM1", 
        "GAM2", "svm1", "nai1", "svm2", "gbm2", "ran2"), rst = c(17.6, 
        16.4, 15, 12.8, 9, 6.2, 5.8, -2.6, -3, -9.2), prec = c(0.466, 
        0.434, 0.435, 0.5, 0.41, 0.8, 0.44, 0.346, 0.345, 0.337), 
            rorac = c(30.345, 21.579, 21.739, 40, 14.754, 124, 23.2, 
            -3.21, -3.448, -5.542), prPo = c(41.4, 54.3, 35.4, 22.9, 
            43.6, 2.6, 12.8, 57.9, 62.1, 118.6), pos = c(140L, 140L, 
            195L, 140L, 140L, 195L, 195L, 140L, 140L, 140L)), .Names = c("algo", 
        "rst", "prec", "rorac", "prPo", "pos"), row.names = c(5L, 
        9L, 1L, 3L, 4L, 7L, 2L, 8L, 6L, 10L), class = "data.frame")), .Names = c("rst1", 
    "rst5"))), .Names = c("F0", "T0"))

Katakanlah kita ingin menghitung panjang setiap elemen.

mylist <- list(a=1:4,b=2:9,c=10:20)
mylist

$a
[1] 1 2 3 4

$b
[1] 2 3 4 5 6 7 8 9

$c
 [1] 10 11 12 13 14 15 16 17 18 19 20

Jika tujuannya hanya untuk memberi label elemen yang dihasilkan, maka lapply(mylist,length)atau di bawah berfungsi.

sapply(mylist,length,USE.NAMES=T)

 a  b  c 
 4  8 11 

Jika tujuannya adalah untuk menggunakan label di dalam fungsi, maka mapply()berguna dengan mengulang dua objek; elemen daftar dan nama daftar.

fun <- function(x,y) paste0(length(x),"_",y)
mapply(fun,mylist,names(mylist))

     a      b      c 
 "4_a"  "8_b" "11_c" 

@ ferdinand-kraft memberi kami trik hebat dan kemudian memberi tahu kami bahwa kami tidak boleh menggunakannya karena tidak berdokumen dan karena overhead kinerja.

Saya tidak bisa berdebat banyak dengan poin pertama tetapi saya ingin mencatat bahwa overhead seharusnya jarang menjadi perhatian.

mari kita mendefinisikan fungsi aktif sehingga kita tidak perlu memanggil ekspresi kompleks parent.frame()$i[]tetapi hanya .i(), Kami juga akan membuat .n()untuk mengakses nama, yang seharusnya berfungsi untuk fungsionalitas dasar dan purrr (dan mungkin sebagian besar lainnya juga).

.i <- function() parent.frame(2)$i[]
# looks for X OR .x to handle base and purrr functionals
.n <- function() {
  env <- parent.frame(2)
  names(c(env$X,env$.x))[env$i[]]
}

sapply(cars, function(x) paste(.n(), .i()))
#>     speed      dist 
#> "speed 1"  "dist 2"

Sekarang mari kita benchmark fungsi sederhana yang menempel item dari vektor ke indeks mereka, menggunakan pendekatan yang berbeda (operasi ini tentu saja dapat di-vectorized menggunakan paste(vec, seq_along(vec))tetapi bukan itu intinya di sini).

Kami mendefinisikan fungsi benchmarking dan fungsi ploting dan plot hasilnya di bawah ini:

library(purrr)
library(ggplot2)
benchmark_fun <- function(n){
  vec <- sample(letters,n, replace = TRUE)
  mb <- microbenchmark::microbenchmark(unit="ms",
                                      lapply(vec, function(x)  paste(x, .i())),
                                      map(vec, function(x) paste(x, .i())),
                                      lapply(seq_along(vec), function(x)  paste(vec[[x]], x)),
                                      mapply(function(x,y) paste(x, y), vec, seq_along(vec), SIMPLIFY = FALSE),
                                      imap(vec, function(x,y)  paste(x, y)))
  cbind(summary(mb)[c("expr","mean")], n = n)
}

benchmark_plot <- function(data, title){
  ggplot(data, aes(n, mean, col = expr)) + 
    geom_line() +
    ylab("mean time in ms") +
    ggtitle(title) +
    theme(legend.position = "bottom",legend.direction = "vertical")
}

plot_data <- map_dfr(2^(0:15), benchmark_fun)
benchmark_plot(plot_data[plot_data$n <= 100,], "simplest call for low n")

benchmark_plot(plot_data,"simplest call for higher n")

^{Dibuat pada 2019-11-15 oleh paket reprex (v0.3.0)}

Penurunan pada awal grafik pertama adalah kebetulan, abaikan saja.

Kami melihat bahwa jawaban yang dipilih memang lebih cepat, dan untuk jumlah iterasi yang layak .i()solusi kami memang lebih lambat, overhead dibandingkan dengan jawaban yang dipilih adalah sekitar 3 kali overhead penggunaan purrr::imap(), dan jumlah sekitar, 25 ms untuk iterasi 30k, jadi saya kehilangan sekitar 1 ms per 1000 iterasi, 1 detik per juta. Itu sedikit biaya untuk kenyamanan menurut saya.

Cukup tulis lapplyfungsi kustom Anda sendiri

lapply2 <- function(X, FUN){
  if( length(formals(FUN)) == 1 ){
    # No index passed - use normal lapply
    R = lapply(X, FUN)
  }else{
    # Index passed
    R = lapply(seq_along(X), FUN=function(i){
      FUN(X[[i]], i)
    })
  }

  # Set names
  names(R) = names(X)
  return(R)
}

Kemudian gunakan seperti ini:

lapply2(letters, function(x, i) paste(x, i))