आर

Question

में बहुआयामी सरणी गुणा, मैं कुछ जटिल बहुआयामी सरणी गुणा करना चाहता हूं जहां मैं सरणी के विशिष्ट मार्जिन पर गुणा करता हूं।

इस उदाहरण पर विचार, जहां मैं एक समूह सुविधा (ए और बी) की आबादी में से कुछ अंतर से की व्यापकता है:

# setup data 

random=runif(4) 

group.prevalence <- aperm (array(c(random,1-random), 
        dim=c(2,2,2), 
        dimnames=list(age=c("young","old"), 
           gender=c("male","female"), 
           group=c("A","B"))) , c(3,1,2)) 

group.prevalence 
# A + B = 1 

अब है कि मैं ब्याज की आबादी मान लीजिए ...

population <- round(array(runif(4, min=100,max=200) %o% c(1,1*(1+random[1]),1*(1+random[1])^2), 
          dim=c(2,2,3), dimnames=list(age=c("young","old"), 
                 gender=c("male","female"), 
                 year=c("year1","year2","year3")))) 

population 

... जिसके लिए मैं "ए" और "बी" के प्रसार की गणना करना चाहता हूं।

बुरा समाधान एक पाश में यह सब भरने के लिए होगा:

# bad solution 
grouped.population <- array(NA, dim=c(2,2,2,3), 
          dimnames=list(group=c("A","B"), 
              age=c("young","old"), 
              gender=c("male","female"), 
              year=c("year1","year2","year3"))) 

for (group in c("A","B")) 
    for(gender in c("male","female")) 
    for (age in c("young","old")) 
     grouped.population[group,age,gender,] <- group.prevalence[group,age,gender] * population[age,gender,] 

लेकिन मुझे लगता है कि लागू किसी प्रकार का, काम, संभवतः plyr के aaply में आ सकता है क्योंकि परिणाम के आयाम बनाए रखा जाना चाहिए। मैंने कोशिश की है:

library(plyr) 
aaply(population, c(1,2), function(x) x * group.prevalence) 
# too many dimensions 

मैं किसी भी सुझाव का स्वागत करता हूं।

Answer 1

अपने विशेष मामले के लिए, आप की गणना कर सकते हैं:

out <- rep(group.prevalence, times=last(dim(population))) * 
     rep(population, each=first(dim(group.prevalence))) 

और उसके बाद आप इस array के आयाम स्थापित कर सकते हैं:

array(out, dim=c(2,2,2,3), 
     dimnames=list(group=c("A","B"), 
        age=c("young","old"), 
        gender=c("male","female"), 
        year=c("year1","year2","year3"))) 

संरेखित दो के आयामों के लिए महत्वपूर्ण है आयामों के के माध्यम से सरणी और विस्तार/प्रतिकृति गुम आयामों को भरने के लिए अन्य सरणी में। सामान्य तौर पर, प्रक्रिया है:

1. अन्तर्विभाजक आयामों को पहचानें। यहां, यह (age,gender) है।
2. गुणा करने के लिए बाएं हाथ की तरफ, group.prevalence, आयामों को अनुमति दें (aperm का उपयोग करके) ताकि सभी गैर-अंतरण आयाम (यानी, group) पहले हों। फिर, उस सरणी N बार (times का उपयोग करके) को दोहराएं) जहां N दाएं हाथ की ओर तर्क, population के गैर-अंतरण आयामों (यानी year) का आकार है।
3. गुणा करने के दाएं हाथ की तरफ, population, आयामों को अनुमति दें ताकि सभी गैर-अंतरण आयाम (यानी, year) अंतिम हैं। फिर, सरणी M बार (each का उपयोग करके) के प्रत्येक तत्व को दोहराएं जहां M बाएं हाथ की ओर तर्क, group.prevalence के गैर-अंतरण आयामों (यानी group) का आकार है।
4. फिर बस (सरणी) गुणा करें, जो वेक्टरकृत और तेज़ है।
5. संयुक्त परिणाम के आयामों, बस बाएं हाथ की ओर तर्क के न काटने वाली आयाम, अन्तर्विभाजक आयाम जिसके बाद दाहिने हाथ की ओर से न काटने वाली आयाम के बाद (अर्थात, (group, age, gender, year))।फिर आप जो भी चाहते हैं उसे प्राप्त करने के लिए आउटपुट में आवश्यकतानुसार इन आयामों को अनुमति दे सकते हैं।

एक चेक के रूप में:

library(microbenchmark) 

f1 <- function(group.prevalence, population) { 
    grouped.population <- array(NA, dim=c(2,2,2,3), 
           dimnames=list(group=c("A","B"), 
              age=c("young","old"), 
              gender=c("male","female"), 
              year=c("year1","year2","year3"))) 
    for (group in c("A","B")) { 
    for(gender in c("male","female")) { 
     for (age in c("young","old")) { 
     grouped.population[group,age,gender,] <- group.prevalence[group,age,gender] * population[age,gender,]}}} 
} 

f2 <- function(group.prevalence, population) { 
    grouped.population2 <- array(rep(group.prevalence, times=last(dim(population))) * 
           rep(population, each=first(dim(group.prevalence))), 
           dim=c(2,2,2,3), 
           dimnames=list(group=c("A","B"), 
              age=c("young","old"), 
              gender=c("male","female"), 
              year=c("year1","year2","year3"))) 
} 

print(microbenchmark(f1(group.prevalence, population))) 
##Unit: microseconds 
##        expr  min  lq  mean median  uq  max neval 
## f1(group.prevalence, population) 101.473 103.998 149.2562 106.8865 115.372 1185.32 100 
print(microbenchmark(f2(group.prevalence, population))) 
##Unit: microseconds 
##        expr min  lq  mean median  uq  max neval 
## f2(group.prevalence, population) 66.392 67.672 70.19873 68.454 69.4205 173.284 100 

मेरा मानना ​​है कि प्रदर्शन आयाम की संख्या और प्रत्येक आयाम में आकार के रूप में और भी अधिक वितरित हो जाएगा:

# bad solution 
grouped.population <- array(NA, dim=c(2,2,2,3), 
          dimnames=list(group=c("A","B"), 
              age=c("young","old"), 
              gender=c("male","female"), 
              year=c("year1","year2","year3"))) 

for (group in c("A","B")) 
    for(gender in c("male","female")) 
    for (age in c("young","old")) 
     grouped.population[group,age,gender,] <- group.prevalence[group,age,gender] * population[age,gender,] 

# another approach 
grouped.population2 <- array(rep(group.prevalence, times=last(dim(population))) * 
          rep(population, each=first(dim(group.prevalence))), 
          dim=c(2,2,2,3), 
          dimnames=list(group=c("A","B"), 
              age=c("young","old"), 
              gender=c("male","female"), 
              year=c("year1","year2","year3"))) 

# check 
all.equal(grouped.population,grouped.population2) 
##[1] TRUE 

---

बेंचमार्क के साथ अपडेट किया बढ़ती है।