1

我正在尝试制作一个脚本来使用 R 生成一组具有人口统计信息的随机人。我希望它按行而不是按列生成，以便函数可以基于同一行中前一个函数的结果。我知道这可以通过 for 循环来完成（如下所示），但 for 循环在 R 中非常慢。我读过您可以使用apply或while更有效地执行循环，但我还没有弄清楚如何尽管许多尝试都失败了。下面是带有循环的功能代码示例。我将如何使用apply或while来做到这一点？

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)
}
4

3 回答 3

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)

教育分布 性别分布 年龄直方图

于 2013-03-06T22:21:32.440 回答
0

我会修改 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))
于 2013-03-06T21:29:58.680 回答
0

对于 main 函数，您可以使用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)
}

您可能还可以进行其他改进。

于 2013-03-06T21:32:12.960 回答