1

Rを使用して人口統計情報を持つランダムな人々のセットを生成するスクリプトを作成しようとしています.関数が同じ行の前の関数の結果に基づくことができるように、列ではなく行で生成したい. これはforループで実行できることは知っていますが（以下で行ったように）、Rではforループが非常に遅くなります.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

したがって、コードを記述した方法は、少なくとも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)

Eduディストリビューション 性別の分布 年齢ヒストグラム

于 2013-03-06T22:21:32.440 に答える
0

applymain関数には、関数ファミリーの何か、つまりを使用できますreplicate。for速度の向上は、Rがコピーによる割り当て言語であり、ループがデータフレームを不必要にコピーするという事実に由来します。

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 に答える
0

スコープ付きの「i」を使用するのではなく、IDを取り込むようにRows関数を変更します。

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 に答える