यादृच्छिक संतुलित प्रयोगात्मक डिजाइन

Question

मैं बाजार अनुसंधान के लिए संतुलित प्रयोगात्मक डिज़ाइन उत्पन्न करने के लिए कुछ कोड लिख रहा हूं, विशेष रूप से conjoint विश्लेषण और अधिकतम अंतर स्केलिंग में उपयोग के लिए।

पहला कदम आंशिक रूप से संतुलित अपूर्ण ब्लॉक (पीबीआईबी) डिज़ाइन उत्पन्न करना है। यह आर पैकेज AlgDesign का उपयोग कर सीधे आगे है।

अधिकांश प्रकार के शोध के लिए ऐसा डिज़ाइन पर्याप्त होगा। हालांकि, बाजार अनुसंधान में प्रत्येक ब्लॉक में ऑर्डर प्रभावों के लिए नियंत्रण करना चाहता है। यह वह जगह है जहां मैं कुछ मदद की सराहना करता हूं।

बनाएं परीक्षण डाटा

# The following code is not essential in understanding the problem, 
# but I provide it in case you are curious about the origin of the data itself. 
#library(AlgDesign) 
#set.seed(12345) 
#choices <- 4 
#nAttributes <- 7 
#blocksize <- 7 
#bsize <- rep(choices, blocksize) 
#PBIB <- optBlock(~., withinData=factor(1:nAttributes), blocksizes=bsize) 
#df <- data.frame(t(array(PBIB$rows, dim=c(choices, blocksize)))) 
#colnames(df) <- paste("Item", 1:choices, sep="") 
#rownames(df) <- paste("Set", 1:nAttributes, sep="") 

df <- structure(list(
    Item1 = c(1, 2, 1, 3, 1, 1, 2), 
    Item2 = c(4, 4, 2, 5, 3, 2, 3), 
    Item3 = c(5, 6, 5, 6, 4, 3, 4), 
    Item4 = c(7, 7, 6, 7, 6, 7, 5)), 
    .Names = c("Item1", "Item2", "Item3", "Item4"), 
    row.names = c("Set1", "Set2", "Set3", "Set4", "Set5", "Set6", "Set7"), 
    class = "data.frame") 

** दो सहायक कार्यों

balanceMatrix परिभाषित करें मैट्रिक्स का संतुलन गणना करता है:

balanceMatrix <- function(x){ 
    t(sapply(unique(unlist(x)), function(i)colSums(x==i))) 
} 

balanceScore 'फिट' का एक मीट्रिक की गणना - निचले स्कोर बेहतर हैं, शून्य सही के साथ:

balanceScore <- function(x){ 
    sum((1-x)^2) 
} 

एक समारोह है कि यादृच्छिक

findBalance <- function(x, nrepeat=100){ 
    df <- x 
    minw <- Inf 
    for (n in 1:nrepeat){ 
     for (i in 1:nrow(x)){df[i,] <- sample(df[i, ])} 
     w <- balanceMatrix(df) 
     sumw <- balanceScore(w) 
     if(sumw < minw){ 
      dfbest <- df 
      minw <- sumw 
     } 
    } 
    dfbest 
} 

मुख्य कोड

dataframe df 7 सेट का एक संतुलित डिजाइन है पर पंक्तियों resamples को परिभाषित करें। प्रत्येक सेट उत्तरदाता को 4 आइटम प्रदर्शित करेगा। df में संख्यात्मक मान 7 अलग-अलग विशेषताओं को संदर्भित करते हैं। उदाहरण के लिए, सेट 1 उत्तरदाता में गुण 1, 3, 4 और 7 से अपना पसंदीदा विकल्प चुनने के लिए कहा जाएगा।

प्रत्येक सेट में आइटमों का क्रम अवधारणात्मक रूप से महत्वपूर्ण नहीं है। इस प्रकार (1,4,5,7) का आदेश (7,5,4,1) के समान है।

हालांकि, पूरी तरह से संतुलित डिज़ाइन प्राप्त करने के लिए, प्रत्येक विशेषता प्रत्येक कॉलम में बराबर संख्या में दिखाई देगी। इस डिजाइन वहाँ असंतुलित है, के बाद से विशेषता 1 कॉलम 1 में 4 बार प्रकट होता है:

df 

    Item1 Item2 Item3 Item4 
Set1  1  4  5  7 
Set2  2  4  6  7 
Set3  1  2  5  6 
Set4  3  5  6  7 
Set5  1  3  4  6 
Set6  1  2  3  7 
Set7  2  3  4  5 

कोशिश करते हैं और एक और अधिक संतुलित डिजाइन खोजने के लिए, मैं समारोह findBalance लिखा था। यह df की पंक्तियों में यादृच्छिक रूप से नमूना करके, बेहतर समाधानों के लिए एक यादृच्छिक खोज आयोजित करता है।

set.seed(12345) 
dfbest <- findBalance(df, nrepeat=100) 
dfbest 

    Item1 Item2 Item3 Item4 
Set1  7  5  1  4 
Set2  6  7  4  2 
Set3  2  1  5  6 
Set4  5  6  7  3 
Set5  3  1  6  4 
Set6  7  2  3  1 
Set7  4  3  2  5 

यह और अधिक संतुलित दिखाई देती है और गणना संतुलन मैट्रिक्स लोगों की बहुत सारी शामिल हैं: 100 दोहराता के साथ यह निम्नलिखित सबसे अच्छा समाधान पाता है। बैलेंस मैट्रिक्स प्रत्येक कॉलम में प्रत्येक विशेषता प्रदर्शित होने की संख्या की गणना करता है।उदाहरण के लिए, निम्न तालिका इंगित करता है (ऊपर बाएं हाथ सेल में) उस गुण 1 दो बार बिल्कुल स्तंभ 1 में नहीं दिखाई देता है, और स्तंभ 2 में दो बार:

balanceMatrix(dfbest) 

    Item1 Item2 Item3 Item4 
[1,]  0  2  1  1 
[2,]  1  1  1  1 
[3,]  1  1  1  1 
[4,]  1  0  1  2 
[5,]  1  1  1  1 
[6,]  1  1  1  1 
[7,]  2  1  1  0 

संतुलन स्कोर के लिए इस समाधान 6 , वहाँ का संकेत कम से कम छह कोशिकाओं 1 के लिए असमान हैं:

balanceScore(balanceMatrix(dfbest)) 
[1] 6 

मेरा प्रश्न

इस विस्तृत उदाहरण निम्नलिखित के लिए धन्यवाद। मेरा सवाल यह है कि मैं इस खोज फ़ंक्शन को और व्यवस्थित करने के लिए कैसे लिख सकता हूं? मैं करने के लिए आर बताना चाहूँगा:

• कम से कम balanceScore(df)
• के df
• विषय पंक्ति आदेश को बदलने द्वारा: पहले से ही पूरी तरह से विवश

Answer 1

ठीक है, मैं किसी भी तरह अपने प्रश्न को गलत समझा। तो अलविदा अलविदा Fedorov, हैलो Fedorov लागू किया।

निम्नलिखित कलन विधि फेदोरोव एल्गोरिथ्म की दूसरी यात्रा पर आधारित है:

1. calculate प्रत्येक सेट के लिए सभी संभव क्रमचय, और उन्हें C0 सूची में स्टोर
2. C0 से पहले संभव समाधान आकर्षित अंतरिक्ष (प्रत्येक सेट के लिए एक क्रमपरिवर्तन)। यह मूल हो सकता है, लेकिन जैसा कि मुझे सूचकांक की आवश्यकता है, मैं बस यादृच्छिक रूप से शुरू करता हूं।
3. प्रत्येक नए समाधान के लिए स्कोर की गणना करें, जहां पहला सेट सभी क्रमपरिवर्तनों द्वारा प्रतिस्थापित किया गया है।
4. सबसे कम स्कोर
5. हर दूसरे सेट
6. दोहराने 3-5 स्कोर तक के लिए दोहराने 3-4 0 या के लिए n पुनरावृत्तियों तक पहुँच जाता देने क्रमचय के साथ पहला सेट की जगह।

वैकल्पिक रूप से, आप 10 पुनरावृत्तियों के बाद प्रक्रिया को पुनः आरंभ और एक अन्य प्रारंभिक बिंदु से शुरू कर सकते हैं।

> X <- findOptimalDesign(df) 
> balanceScore(balanceMatrix(X)) 
[1] 0 
> mean(replicate(20, system.time(X <- findOptimalDesign(df))[3])) 
[1] 1.733 

तो यह है: आप परीक्षण मामले में, यह कुछ शुरुआती बिंदु को 0 पर बहुत धीरे धीरे कन्वर्ज्ड कि समारोह नीचे अपने कंप्यूटर पर औसत 1.5 सेकंड पर में 0 के स्कोर के साथ संतुलित प्रयोगात्मक डिजाइन पाया निकला

findOptimalDesign <- function(x,iter=4,restart=T){ 
    stopifnot(require(combinat)) 
    # transform rows to list 
    sets <- unlist(apply(x,1,list),recursive=F) 
    nsets <- NROW(x) 
    # C0 contains all possible design points 
    C0 <- lapply(sets,permn) 
    n <- gamma(NCOL(x)+1) 

    # starting point 
    id <- sample(1:n,nsets) 
    Sol <- sapply(1:nsets,function(i)C0[[i]][id[i]]) 

    IT <- iter 
    # other iterations 
    while(IT > 0){ 
     for(i in 1:nsets){ 
      nn <- 1:n 
      scores <- sapply(nn,function(p){ 
      tmp <- Sol 
      tmp[[i]] <- C0[[i]][[p]] 
      w <- balanceMatrix(do.call(rbind,tmp)) 
      balanceScore(w) 
      }) 
      idnew <- nn[which.min(scores)] 
      Sol[[i]] <- C0[[i]][[idnew]] 

     } 
     #Check if score is 0 
     out <- as.data.frame(do.call(rbind,Sol)) 
     score <- balanceScore(balanceMatrix(out)) 
     if (score==0) {break} 
     IT <- IT - 1 

     # If asked, restart 
     if(IT==0 & restart){ 
      id <- sample(1:n,nsets) 
      Sol <- sapply(1:nsets,function(i)C0[[i]][id[i]]) 
      IT <- iter 
     } 
    } 
    out 
} 

HTH

संपादित करें: छोटे बग तय (यह हर दौर के बाद तुरंत पुन: प्रारंभ करने के रूप में मैं इस पर हालत भूल गया) समारोह अब (आपके मूल balanceMatrix और balanceScore कार्यों को देखते हुए)। ऐसा करने से, यह अभी भी थोड़ा तेज़ चलता है।