裏 RjpWiki

文字通り,RjpWiki の裏を行きます
R プログラム コンピュータ・サイエンス 統計学

"2014 NHPI NHIS Data" を R にインポート Ver. 2

2020年07月17日 | ブログラミング

最新版は以下を参照

"2014 NHPI NHIS Data" を R にインポート Ver. 3
https://blog.goo.ne.jp/r-de-r/e/23dae09d759881be24d0bb2a645ce8ac

"2014 NHPI NHIS Data" を Python にインポート Ver. 1
https://blog.goo.ne.jp/r-de-r/e/c25c3b84e3e1e50136958939501380b0

 

factor() の labels を base::abbreviate() で短縮するオプションを付加

parse = function(fn, df.name = "df", abbreviate = TRUE, minlength = 10, verbose = FALSE) {
  # fn:  *.zip ファイル(入力) unzip されアスキーデータ *.dat ができる
  # invisible() でデータフレームを返す
  # *.csv ファイルを書く
  # 変数情報についてのデータフレーム *-info.csv に書く
  # R でfactor 変数を定義するための R コードを *-factor.R に書く
  # abbreviate = TRUE のとき,factor() の labels を minlength の長さで短縮する

  parse2 = function(df, arg) {
    pos = grep(arg[1], df$variable)
    df[pos, "from"] = as.integer(arg[2])
    df[pos, "to"]   = as.integer(arg[4])
    type = ""
    if (length(arg) == 5) {
      type = arg[5]
    }
    df[pos, "type"] = type
    return(df)
  }

  base = sub("\\.dat", "", sub("./", "", unzip(fn)))
  fn = paste0(toupper(base), ".sps")
  src = readLines(fn)
  src = sub("^ +", "", src)
  src = sub("\xfc\xbe\x8d\x93\xa0\xbc", " ", src) # "Ö" SAMADULT.sps などに特有
  src = sub("\xfc\xbe\x8c\xa3\xa4\xbc", "'", src) # "í" SAMADULT.sps などに特有
  pos = grep("LRECL", src)
  # 最大読み取り桁
  lrecl = as.integer(unlist(strsplit(src[pos], "="))[2])
  # df に,変数名と変数ラベルを取り出す
  begin = which(src == "VARIABLE LABELS") + 1
  end   = which(src == "VALUE LABELS") - 3
  n.variables = end - begin + 1
  variable = character(n.variables)
  label = character(n.variables)
  for (i in begin:end) {
    j = i - begin + 1
    variable[j] = sub(" +", "", substr(src[i], 1, 8))
    label   [j] = sub("\\\"", "", substr(src[i], 12, nchar(src[i])))
  }
  # df に,読み出し桁数の情報を追加する
  df = data.frame(variable, label, from=0, to=0, width=0, type="")
  begin = which(grepl("DATA LIST FILE", src)) + 1
  end   = which(src == "VARIABLE LABELS") - 3
  for (i in begin:end) {
    field = unlist(strsplit(src[i], " +"))
    pos = which(field %in% df$variable)
    if (length(pos) == 1) {
      df = parse2(df, field)
    } else if (length(pos) == 2) {
      df = parse2(df, field[pos[1]:(pos[2] - 1)])
      df = parse2(df, field[pos[2]:length(field)])
    } else {
      print("parse error.")
      return(999)
    }
  }
  df$width = df$to - df$from + 1
  # *.sps の変数に関するデータフレームの書き出し
  fn4 = paste0(base, "-info.csv")
  write.csv(df, fn4, row.names = FALSE)
  # データフレームとして読み込み
  if (sum(df$width) != lrecl) {
    cat("widths error. sum of widths =", sum(df$width), ", lrecl =", lrecl, "\n")
    return(999)
  }
  fn5 = paste0(base, ".dat")
  cat(sprintf("read %s...\n", fn5))
  df2 = read.fwf(fn5, width = df$width)
  colnames(df2) = df$variable
  n = nrow(df2)
  cat(sprintf("     %d cases, %d variables\n", n, n.variables))
  # csv ファイル書き出し
  fn6 = paste0(base, ".csv")
  write.csv(df2, fn6, row.names = FALSE)
  ###
  # もっとも単純にデータをインポートするだけなら,以下は要らない。
  begin = which(src == "VALUE LABELS") + 1
  end   = which(src == "EXECUTE.")
  fn7 = paste0(base, "-factor.R")
  write("# read.csv() then source(*this file*)", fn7)
  for (i in begin:end) {
    if (i == begin) {
      old.str = new.str = NULL
      variable = src[i]
    } else if (nchar(src[i]) == 0 || substr(src[i], 1, 1) == "/") {
      if (verbose) {
        cat("decoding...", variable, "\n")
      }
      if (abbreviate) {
        new.str = base::abbreviate(new.str, minlength = minlength, named = FALSE)
        new.str = paste(old.str, new.str, sep=":")
      }
      df2[, variable] = factor(df2[, variable], levels = old.str, labels = new.str)
      old.str2 = paste(old.str, collapse = ", ")
      new.str2 = paste(sprintf("\"%s\"", new.str), sep = ", ", collapse = ", ")
      cat(sprintf('%s$%s = factor(%s$%s, levels=c(%s), labels=c(%s))\n',
          df.name, variable, df.name, variable, old.str2, new.str2 ),
          file = fn7, append = TRUE)
      if (nchar(src[i]) == 0) {
        break
      }
      old.str = new.str = NULL
      variable = unlist(strsplit(src[i], " "))[2]
    } else {
      field = unlist(strsplit(src[i],  "\\\""))
      if (length(field) == 2) { # SAMADULT.sps などで例外
        old.str = c(old.str, as.integer(field[1]))
        new.str = c(new.str, field[2])
      }
    }
  }
  invisible(df2)
}

コメント (2)   この記事についてブログを書く
« COVID-19 陽性確定日ごとの患... | トップ | "2014 NHPI NHIS Data" を R ... »
最新の画像もっと見る

2 コメント

コメント日が  古い順  |   新しい順
Unknown (中澤)
2020-07-22 14:13:02
素晴らしいコードありがとうございます。
ただ,これを実行してできるファイルで,personsx.csvをdfに読み込んでからpersonsx-factor.Rを実行すると,AGE_Pのような数値変数が0歳と75歳以上とその他という3カテゴリだけのfactor型になってしまって,元の数値情報が消えてしまいました。
こういうファクター化したくない変数については,やはり手作業でコメントアウトするしかないでしょうか。
Ver.3 公開 (r-de-r)
2020-07-24 07:52:51
この件については,しばらく前に気づきました。
やっと,23日に対応し Ver.3 を掲示しました。
以下のようになると思います。
なお,Ver.3 からは,csv ファイルを読んで factor() を適用するというのを *-template.R というファイルにまとめることにしました。

> cbind(table(personsx$AGE_P))
[,1]
1 135
2 163
3 170
:
73 51
74 46
0:Under1year 135
75:75+ years 389

コメントを投稿

ブログ作成者から承認されるまでコメントは反映されません。

ブログラミング」カテゴリの最新記事