2011-12-27 30 views
7

में समूहवार निरंतर कॉलम का कुशलता से पता लगाएं I डेटा फ्रेम से समूहवार निरंतर कॉलम को कुशलतापूर्वक कैसे निकाला जा सकता है? मैंने सटीक बनाने के लिए नीचे एक प्लीयर कार्यान्वयन शामिल किया है जो मैं करने की कोशिश कर रहा हूं, लेकिन यह धीमा है। मैं इसे यथासंभव कुशलतापूर्वक कैसे कर सकता हूं? (आदर्श रूप से डेटा फ्रेम को विभाजित किए बिना)।डेटा-फ्रेम

base <- data.frame(group = 1:1000, a = sample(1000), b = sample(1000)) 
df <- data.frame(
    base[rep(seq_len(nrow(base)), length = 1e6), ], 
    c = runif(1e6), 
    d = runif(1e6) 
) 


is.constant <- function(x) length(unique(x)) == 1 
constant_cols <- function(x) head(Filter(is.constant, x), 1) 
system.time(constant <- ddply(df, "group", constant_cols)) 
# user system elapsed 
# 20.531 1.670 22.378 
stopifnot(identical(names(constant), c("group", "a", "b"))) 
stopifnot(nrow(constant) == 1000) 

मेरी वास्तविक उपयोग मामले में (गहरी ggplot2 के अंदर) वहाँ लगातार और गैर लगातार स्तंभों की एक मनमाना संख्या हो सकती है। उदाहरण में डेटा का आकार परिमाण के सही क्रम के बारे में है।

+0

आप पहले से ही plyr उपयोग करके किसी भी शुद्ध आर कार्यान्वयन की तुलना में बेहतर कर रहे हैं। आईएमएचओ आप समूह द्वारा डीएफ को सॉर्ट करके (तेज़ तेज़) और फिर सी कोड में ब्रेक के लिए स्कैनिंग करके बेहतर कर सकते हैं। –

+0

@ सिमॉन मैं प्लीयर के साथ किसी भी पंक्ति आधारित समाधान से बेहतर कर रहा हूं - मुझे लगता है कि यद्यपि एक चालाक कॉलम आधारित समाधान होना चाहिए। – hadley

उत्तर

3

@ Joran के जवाब से प्रेरित होकर, यहाँ समान रणनीति है कि एक छोटे से तेजी से (1 रों बनाम मेरी मशीन पर 1.5 रों)

changed <- function(x) c(TRUE, x[-1] != x[-n]) 

constant_cols2 <- function(df,grp){ 
    df <- df[order(df[,grp]),] 
    n <- nrow(df) 
    changes <- lapply(df, changed) 

    vapply(changes[-1], identical, changes[[1]], FUN.VALUE = logical(1)) 
} 
system.time(cols <- constant_cols2(df, "group")) # about 1 s 

system.time(constant <- df[changed(df$group), cols]) 
# user system elapsed 
# 1.057 0.230 1.314 

stopifnot(identical(names(constant), c("group", "a", "b"))) 
stopifnot(nrow(constant) == 1000) 

यह है कि यह कॉलम का पता नहीं लगा है, हालांकि एक ही खामियां है कि

constant_cols3 <- function(df, grp) { 
    # If col == TRUE and group == FALSE, not constant 
    matching_breaks <- function(group, col) { 
    !any(col & !group) 
    } 

    n <- nrow(df) 
    changed <- function(x) c(TRUE, x[-1] != x[-n]) 

    df <- df[order(df[,grp]),] 
    changes <- lapply(df, changed) 
    vapply(changes[-1], matching_breaks, group = changes[[1]], 
    FUN.VALUE = logical(1)) 
} 

system.time(x <- constant_cols3(df, "group")) 
# user system elapsed 
# 1.086 0.221 1.413 

और वह सही परिणाम देता है: थोड़ा और सोच के साथ प्लस @ दाऊद के विचारों

आसन्न समूहों के लिए समान मूल्यों (df$f <- 1 जैसे) कर रहे हैं ।

+0

का उपयोग करता है यह सिर्फ मेरे लिए हुआ है कि आप '0: 1' वेक्टर जोड़कर आसन्न समूहों की समस्या में समान मूल्यों को हल करने में सक्षम हो सकते हैं 'rle' करने से पहले 'समूह' के साथ दोहराए जाने वाले प्रत्येक कॉलम पर। – joran

+0

हम्म, डेटा फ्रेम को सॉर्ट करने की बजाय यदि तेज़ लगता है, तो मैं व्यक्तिगत कॉलम को सॉर्ट करता हूं क्योंकि मैं परिवर्तनों की गणना करता हूं। – hadley

3

(संपादित करें: बेहतर जवाब)

क्या तरह

is.constant<-function(x) length(which(x==x[1])) == length(x)

कुछ के बारे में यह एक अच्छा सुधार हो रहा है। निम्नलिखित की तुलना करें।

> a<-rnorm(5000000) 

> system.time(is.constant(a)) 
    user system elapsed 
    0.039 0.010 0.048 
> 
> system.time(is.constantOld(a)) 
    user system elapsed 
    1.049 0.084 1.125 
+0

आह, लेकिन अपने पुराने कोड में डालने से, is.constant बाधा प्रतीत नहीं होता है। एचआरएम ... फिर भी, हर बिट मदद करता है, आह? – jebyrnes

+0

मैंने सोचा होगा 'is.constant <- function (x)! कोई भी (x [1]! = X)' और भी बेहतर होगा। लेकिन आप सही हैं कि यह बाधा नहीं है - यह धीमा है कि डेटा फ्रेम का विभाजन और संयोजन है। – hadley

4

(संभवतः एक ही मूल्य के साथ लगातार समूहों के मुद्दे का समाधान करने के लिए संपादित)

मैं अंतरिम रूप से इस सवाल का जवाब प्रस्तुत करने हूँ, लेकिन मैं पूरी तरह से अपने आप को आश्वस्त नहीं है कि इसे सही ढंग से भीतर की पहचान करेगा सभी मामलों में समूह निरंतर कॉलम। लेकिन यह निश्चित रूप से तेज है (और शायद सुधार किया जा सकता):

constant_cols1 <- function(df,grp){ 
    df <- df[order(df[,grp]),] 

    #Adjust values based on max diff in data 
    rle_group <- rle(df[,grp]) 
    vec <- rep(rep(c(0,ceiling(diff(range(df)))), 
       length.out = length(rle_group$lengths)), 
       times = rle_group$lengths) 
    m <- matrix(vec,nrow = length(vec),ncol = ncol(df)-1) 
    df_new <- df 
    df_new[,-1] <- df[,-1] + m 

    rles <- lapply(df_new,FUN = rle) 
    nms <- names(rles) 
    tmp <- sapply(rles[nms != grp], 
        FUN = function(x){identical(x$lengths,rles[[grp]]$lengths)}) 
    return(tmp) 
} 

मेरे मूल विचार rle उपयोग करने के लिए, स्पष्ट रूप से किया गया था।

+0

हमम, मुझे लगता है कि यह काम नहीं करेगा यदि मान कई समूहों में समान है (इसलिए लंबाई 2000 होगी)। वास्तव में दिलचस्प दृष्टिकोण हालांकि – hadley

+0

@ हैडली ड्रैट, आप सही हैं। – joran

+0

मुझे लगता है कि यह मेरे दृष्टिकोण में ठीक करना आसान होना चाहिए जो आपके समान काम करता है लेकिन लॉजिकल वैक्टर – hadley

4

मुझे यकीन है कि अगर यह आप के लिए वास्तव में क्या देख रहे है नहीं कर रहा हूँ, लेकिन यह कॉलम ए और बी को पहचानती है।

require(data.table) 
is.constant <- function(x) identical(var(x), 0) 
dtOne <- data.table(df) 
system.time({dtTwo <- dtOne[, lapply(.SD, is.constant), by=group] 
result <- apply(X=dtTwo[, list(a, b, c, d)], 2, all) 
result <- result[result == TRUE] }) 
stopifnot(identical(names(result), c("a", "b"))) 
result 
+0

दुर्भाग्य से मैं इसे यथासंभव कुछ बाहरी निर्भरताओं के साथ करने की कोशिश कर रहा हूं, लेकिन यह मेरे कंप्यूटर पर 0.5 एस के लिए लक्ष्य करने का समय देता है। – hadley

+0

मैंने कुल मिलाकर एक ही चीज़ करने की कोशिश की और 0.3 सेकंड के डेटाटेबल के बजाय वे लगभग 10 और 18 सेकंड के परिणामस्वरूप शोध कर रहे थे। – Jared

+0

हां, क्योंकि एक बड़ी बाधा डेटा फ्रेम को सब्सक्राइब कर रही है - यह धीमा है क्योंकि यह एक प्रति बनाता है। डेटा टेबल ऐसा नहीं करते हैं, इसलिए यह तेज़ है। – hadley

1

is.unsorted(x) कितनी तेजी से गैर-स्थिर x के लिए विफल रहता है? अफसोस की बात है कि इस समय मुझे आर तक पहुंच नहीं है। ऐसा लगता है कि हालांकि आपकी बाधा नहीं है।

3

एक क्या हेडली से ऊपर का सुझाव दिया की तुलना में धीमी सा है, लेकिन मुझे लगता है कि यह बराबर आसन्न समूहों

findBreaks <- function(x) cumsum(rle(x)$lengths) 

constantGroups <- function(d, groupColIndex=1) { 
    d <- d[order(d[, groupColIndex]), ] 
    breaks <- lapply(d, findBreaks) 
    groupBreaks <- breaks[[groupColIndex]] 
    numBreaks <- length(groupBreaks) 
    isSubset <- function(x) length(x) <= numBreaks && length(setdiff(x, groupBreaks)) == 0 
    unlist(lapply(breaks[-groupColIndex], isSubset)) 
} 

अंतर्ज्ञान है के मामले को संभाल चाहिए कि अगर एक स्तंभ लगातार ग्रुपवाइज है तो स्तंभ मानों में टूट जाता है (समूह मूल्य द्वारा क्रमबद्ध) समूह मूल्य में ब्रेक का सबसेट होगा।

अब, हेडली के साथ तुलना (छोटे संशोधन के साथ n सुनिश्चित करने के लिए परिभाषित किया गया है)

# df defined as in the question 

n <- nrow(df) 
changed <- function(x) c(TRUE, x[-1] != x[-n]) 

constant_cols2 <- function(df,grp){ 
    df <- df[order(df[,grp]),] 
    changes <- lapply(df, changed) 
    vapply(changes[-1], identical, changes[[1]], FUN.VALUE = logical(1)) 
} 

> system.time(constant_cols2(df, 1)) 
    user system elapsed 
    1.779 0.075 1.869 
> system.time(constantGroups(df)) 
    user system elapsed 
    2.503 0.126 2.614 
> df$f <- 1 
> constant_cols2(df, 1) 
    a  b  c  d  f 
TRUE TRUE FALSE FALSE FALSE 
> constantGroups(df) 
    a  b  c  d  f 
TRUE TRUE FALSE FALSE TRUE 
+0

अच्छा! मुझे लगता है कि मेरे संस्करण को उसी रणनीति का उपयोग करने के लिए अनुकूलित करना संभव है, इसलिए यह थोड़ा तेज़ रह सकता है। – hadley

+0

बस सोच के समान लाइन का उपयोग करने के जवाब के रूप में अनुकूलित किया गया है, लेकिन तार्किक वैक्टर के साथ। धन्यवाद! – hadley

संबंधित मुद्दे