替代for循环的唯一行，以填补data.frame

Question

我试图让一个脚本来生成随机的一组使用R.与人口统计信息的人，我希望它按行产生，而不是列，这样的功能可以基于同一行中前一个函数的结果。我知道这可以用做对环（像我一样下文），但for循环非常慢R.我已阅读，你可以使用申请或而以更有效地做一个循环，但我的天堂”尽管许多尝试失败，但我仍然想到了如何。以下是带有循环的功能代码示例。我将如何做到这一点与适用或而？

y <- 1980 ## MedianYr 
d <- 0.1 ## Rate of NA responses 

AgeFn <- function(y){ 
    Year <- 1900 + as.POSIXlt(Sys.Date())$year 
    RNormYr <- as.integer((rnorm(1)*10+y)) 
    Age <- Year - RNormYr 
} 

EduByAge <- function (Age, d) { 
    ifelse(Age < 17, sample(c("Some High School",NA), size=1,prob=c((1-d),d)), 
    ifelse(Age > 16 & Age < 19, sample(c("Some High School", "High School Grad",NA), size=1, prob=c(0.085, 0.604,d)), 
     ifelse(Age > 18 & Age < 21, sample(c("Some High School", "High School Grad", "Associates",NA), size=1,prob=c(0.085, 0.25, 0.354,d)), 
     ifelse(20 > Age & Age < 23, sample(c("Some High School", "High School Grad", "Associates", "Bachelors",NA), size=1,prob=c(0.085, 0.25, 0.075, 0.279,d)), 
      ifelse(Age > 22, sample(c("Some High School", "High School Grad", "Associates", "Bachelors", "Masters", "Professional", "Doctorate",NA),size=1,prob=c(0.085, 0.25, 0.075, 0.176, 0.072, 0.019, 0.012,d)), NA))))) 
} 

GenderFn <- function(d){ 
    Gender1 <- sample(c("Male","Female","Trans", NA), 1, replace=TRUE, prob=c(0.49, 0.5, 0.01, d)) 
    return(Gender1) 
} 

UserGen <- function(n,s) { 
    set.seed(s) 
    Rows <- function(y,d){ 
    Age <- abs(AgeFn(y)) 
    Gender <- GenderFn(d) 
    Education <- EduByAge(Age,d) 
    c(i, Age, Gender, Education) 
    } 
    df <- data.frame(matrix(NA, ncol = 4, nrow = n)) 
    for(i in (1:n)) { 
    df[i,] <- Rows(y,d) 
    } 
    colnames(df) <- c("ID", "Age", "Gender", "Education") 
    return(df) 
} 

Answer 1

所以，你写你的代码的方式意味着你最终将至少一个循环。

apply用于一个函数应用到每个另一结构的元件。所以，当你想将包含所有年龄的矢量传递给其他函数时，它将起作用。但是，它对于运行您的AgeFn()函数并不是那么热门，因为这不会成为您想要迭代的任何参数。

这里有另一种可能，其中沟渠你赞成sample功能得到随机年龄的方法。我做了一些假设，但我希望解释可以帮助你找出如何在R.

y <- 1980  ## MedianYr 
d <- 0.1  ## Rate of NA responses 
agemin <- 14 
agemax <- 90 

# The stats guy in me thinks that you might have some 
# methodological problems here with how the ages are assigned 
# But I'm just going to stick with it for now 
EduByAge <- function (Age, d) { 
    ifelse(Age < 17, sample(c("Some High School",NA), size=1,prob=c((1-d),d)), 
      ifelse(Age > 16 & Age < 19, sample(c("Some High School", "High School Grad",NA), size=1, prob=c(0.085, 0.604,d)), 
        ifelse(Age > 18 & Age < 21, sample(c("Some High School", "High School Grad", "Associates",NA), size=1,prob=c(0.085, 0.25, 0.354,d)), 
         ifelse(20 > Age & Age < 23, sample(c("Some High School", "High School Grad", "Associates", "Bachelors",NA), size=1,prob=c(0.085, 0.25, 0.075, 0.279,d)), 
           ifelse(Age > 22, sample(c("Some High School", "High School Grad", "Associates", "Bachelors", "Masters", "Professional", "Doctorate",NA),size=1,prob=c(0.085, 0.25, 0.075, 0.176, 0.072, 0.019, 0.012,d)), NA))))) 
} 

NewUserGen <- function(n,s) { 

    set.seed(s) 

    ## Start by creating a data frame with IDs 
    fakedata <- data.frame(ID=1:n) 

    # Rather than a function, here I just used the built-in sample function 
    # I am sampling for n ages lying between agemin and agemax 
    # Using dnorm(), I assume a normal distribution of the ages, with 
    # mean age equal to today's year minus the "MedianYr" you were using above 
    # I assume that the mean and the SD are equal, you don't have to do that 

    # I put in a few extra carriage returns here to make things not quite so 
    # tight together - figured it would be easier to read. 
    fakedata$Age <- sample(x=agemin:agemax,size=n,replace=TRUE, 
          prob= 
          dnorm(agemin:agemax, 
          mean=abs(y-as.numeric(format.Date(Sys.Date(),"%Y"))), 
          sd=abs(y-as.numeric(format.Date(Sys.Date(),"%Y"))))) 

    # I'm sure you know this, but you have some issues here 
    # namely that you have a probability vector that totals to more than 1. 
    # You might be getting no NAs as a result. 
    fakedata$Gender <- sample(c("Male","Female","Trans", NA), 
           n, replace=TRUE, prob=c(0.49, 0.5, 0.01, d)) 

    # Here is the actually sapply() 
    fakedata$Edu <- sapply(fakedata$Age,FUN=EduByAge,d=0.1) 

    return(fakedata) 
} 

outdata <- NewUserGen(300,10201) 

这是数据的外观合计后这一切工作：

outdata$Edu <- factor(outdata$Edu,levels=c("Some High School", 
              "High School Grad", 
              "Associates", 
              "Bachelors", 
              "Masters", 
              "Doctorate"),ordered=TRUE) 

hist(outdata$Age) 
barplot(table((outdata$Gender))) 
par(mai=c(3,1,1,1)) 
barplot(table((outdata$Edu)),las=2) 

Answer 2

我会修改Rows函数以获取ID，而不是使用作用域“i”。

Rows <- function(i, y,d){ 
    Age <- abs(AgeFn(y)) 
    Gender <- GenderFn(d) 
    Education <- EduByAge(Age,d) 
    c(i, Age, Gender, Education) 
} 

然后，你可以调用函数与lapply：

res1 = lapply(1:3000, function(i){ 
    Rows(i, y, d) 
}) 

仅凭这一点并没有真正提高速度，但如果你有多个内核的机器上，你也许能通过它的mclapply函数，从“多核”库中获得一些用处。

library("multicore") 
res2 = mclapply(1:3000, function(i){ 
    Rows(i, y,d) 
}) 

哦，如果你想使用结果作为一个数据帧，你可以这样做：

df = data.frame(do.call(rbind, res1)) 

Answer 3

为主要功能，你可以使用的东西从apply家庭的功能，即replicate。速度的提升来自于一个事实，即R是分配，通过复制语言和for循环不必要拷贝数据帧：

UserGen2 <- function(n,s) { 
    set.seed(s) 
    Rows <- function(y,d) { 
    Age <- abs(AgeFn(y)) 
    Gender <- GenderFn(d) 
    Education <- EduByAge(Age,d) 
    c(Age, Gender, Education) 
    } 
    samp <- t(replicate(n,Rows(y,d))) 
    colnames(samp) <- c("Age","Gender","Education") 
    data.frame(ID=seq_len(dim(samp)[1]),samp) 
} 

可能有其他方面的改进，你可以做的一样好。