diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 000000000..9eefaf1d9 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,34 @@ +name: Continuous Integration + +on: + pull_request: + paths: + - 'code/script/**' + - 'code/SoS/**' + - 'tests/**' + workflow_dispatch: + +concurrency: + group: wrapper-tests-${{ github.ref }} + cancel-in-progress: true + +jobs: + ci: + name: CI (${{ matrix.runner }}) + runs-on: ${{ matrix.runner }} + strategy: + fail-fast: false + matrix: + runner: [ubuntu-latest, macos-latest] + steps: + - name: Checkout repository + uses: actions/checkout@v7 + + - name: Set up pixi environment + uses: prefix-dev/setup-pixi@v0.10.0 + + - name: Script tests + run: pixi run test_scripts + + - name: Notebook tests + run: pixi run test_notebooks diff --git a/.gitignore b/.gitignore index 875b58db6..c9ce401c9 100644 --- a/.gitignore +++ b/.gitignore @@ -55,3 +55,5 @@ renovated_code/snakemake/archive/ renovated_code/snakemake/dryrun/bin/ dev/ + +pixi.lock diff --git a/code/SoS/association_scan/qtl_association_postprocessing.ipynb b/code/SoS/association_scan/qtl_association_postprocessing.ipynb index 364eb3f37..9766c05bc 100644 --- a/code/SoS/association_scan/qtl_association_postprocessing.ipynb +++ b/code/SoS/association_scan/qtl_association_postprocessing.ipynb @@ -155,44 +155,30 @@ "source": [ "[global]\n", "parameter: cwd = path(\".\")\n", - "#path to pecotmr repo\n", - "parameter: pecotmr_path = path\n", - "parameter: gene_coordinates = path\n", + "# code/script dir that holds the pecotmr_integration wrappers\n", + "parameter: modular_script_dir = path\n", "parameter: output_dir = path\n", - "parameter: archive_dir = path\n", - "parameter: sub_dir = path\n", + "parameter: sub_dir = path(\".\")\n", + "# labels for the assembled QtlSumStats\n", + "parameter: study = \"study\"\n", + "parameter: context = \"context\"\n", + "parameter: genome = \"hg38\"\n", "parameter: maf_cutoff = 0.01\n", "parameter: cis_window = 1000000\n", - "parameter: tss_dist_col = \"start_distance\"\n", - "parameter: tes_dist_col = \"end_distance\"\n", "parameter: af_col = \"af\"\n", + "parameter: pvalue_col = \"pvalue\"\n", "parameter: molecular_id_col = \"molecular_trait_object_id\"\n", - "# This is for selecting the subset of data to process on protential signals \n", - "# assuming we drop those above this threshold\n", - "# This might lead to underestimates in qvalue method since qvalue < 0.05 may contain pvalue > 0.05\n", + "# drop pairs with p above this before assembling (keeps the object small; the\n", + "# per-gene min variant is always retained so the Bonferroni min is exact)\n", "parameter: pvalue_cutoff = 0.05\n", - "# This is used for both event and variant level significance filter\n", "parameter: fdr_threshold = 0.05\n", - "# eg \"pvalue\" for pvalue, \"pvalue_.*_interaction\" for interaction\n", - "parameter: pvalue_pattern = \"^pvalue$\"\n", - "# eg \"qvalue\" for pvalue, \"qvalue_interaction\" for interaction\n", - "parameter: qvalue_pattern = \"^qvalue$\"\n", - "# eg \"*.cis_qtl.regional.tsv.gz$\" for genetic effect via our pipeline TensorQTL.ipynb\n", - "# \"*.cis_qtl_top_assoc.txt.gz$\" for interaction genetic effect\n", - "parameter: regional_pattern = \"NULL\"\n", - "parameter: qtl_pattern = \"*.cis_qtl.pairs.tsv.gz$\"\n", - "parameter: n_variants_suffix = \"cis_n_variants_stats.tsv.gz\"\n", + "# list.files() regex patterns to locate the inputs in the work dir\n", + "parameter: regional_pattern = \"cis_qtl[.]regional[.]tsv[.]gz$\"\n", + "parameter: qtl_pattern = \"cis_qtl[.]pairs[.]tsv[.]gz$\"\n", + "parameter: n_variants_suffix = \"cis_n_variants_stats[.]tsv[.]gz$\"\n", "parameter: enable_archive = False\n", - "parameter: additional_pvalue_cols = \"\"\n", "\n", - "work_dir = f\"{cwd:a}/{sub_dir}\"\n", - "if sub_dir == path(\".\"):\n", - " output_dir = f\"{output_dir:a}/{cwd:b}\"\n", - " archive_dir = f\"{archive_dir:a}/{cwd:b}\"\n", - " work_dir = f\"{cwd:a}\"\n", - "else:\n", - " output_dir = f\"{output_dir:a}/{cwd:b}/{sub_dir}\"\n", - " archive_dir = f\"{archive_dir:a}/{cwd:b}/{sub_dir}\"" + "work_dir = cwd if str(sub_dir) == \".\" else path(f\"{cwd:a}/{sub_dir}\")\n" ] }, { @@ -204,59 +190,23 @@ "outputs": [], "source": [ "[default]\n", - "output: f\"{output_dir}/{cwd:b}_multiple_testing_consolidated.rds\"\n", - "task: trunk_workers = 1, tags = f'tensorqtl_postprocessing_{_output:n}'\n", - "R: expand = \"${ }\"\n", - "\n", - " params <- list()\n", - " params$workdir <- \"${work_dir}\"\n", - " params$maf_cutoff <- ${maf_cutoff}\n", - " params$cis_window <- ${cis_window}\n", - " params$pvalue_cutoff <- ${pvalue_cutoff}\n", - " params$fdr_threshold <- ${fdr_threshold}\n", - " params$gene_coordinates <- \"${gene_coordinates:a}\"\n", - " params$output_dir <- \"${output_dir}\"\n", - " params$archive_dir <- \"${archive_dir}\"\n", - " params$regional_pattern <- \"${regional_pattern}\"\n", - " params$n_variants_suffix <- \"${n_variants_suffix}\"\n", - " params$qtl_pattern <- \"${qtl_pattern}\"\n", - " params$pvalue_pattern <- \"${pvalue_pattern}\"\n", - " params$qvalue_pattern <- \"${qvalue_pattern}\"\n", - " params$start_distance_col <- \"${tss_dist_col}\"\n", - " params$end_distance_col <- \"${tes_dist_col}\"\n", - " params$af_col <- \"${af_col}\"\n", - " params$molecular_id_col <- \"${molecular_id_col}\"\n", - " enable_archive_val <- \"${enable_archive}\"\n", - " if (enable_archive_val %in% c(\"True\", \"TRUE\", \"true\")) {\n", - " params$enable_archive <- TRUE\n", - " } else {\n", - " params$enable_archive <- FALSE\n", - " }\n", - " message(sprintf(\"Archive setting - input: '%s', converted: %s\", enable_archive_val, params$enable_archive)) \n", - " params$additional_pvalue_cols <- \"${additional_pvalue_cols}\" \n", - " convert_null_strings <- function(params) {\n", - " if (is.list(params)) {\n", - " # Apply the function to each element in the list\n", - " result <- lapply(params, convert_null_strings)\n", - " return(result)\n", - " } else {\n", - " # For non-list elements, check if it's the string \"NULL\"\n", - " if (is.character(params) && params == \"NULL\") {\n", - " return(NULL)\n", - " } else {\n", - " return(params)\n", - " }\n", - " }\n", - " }\n", - "\n", - " params <- convert_null_strings(params)\n", - " source(\"${pecotmr_path}/inst/code/tensorqtl_postprocessor.R\")\n", - " results <- hierarchical_multiple_testing_correction(params)\n", - " write_results(results, params$output_dir, params$workdir, to_cwd = \"regional\")\n", - " if (params$enable_archive) {\n", - " archive_files(params)\n", - " }\n", - " saveRDS(results, ${_output:r})" + "# Hierarchical multiple-testing correction of the cis-QTL association results,\n", + "# via pecotmr::qtlAssociationPostprocess (the wrapper reads the per-gene regional\n", + "# + per-variant pairs, assembles a per-gene QtlSumStats, and writes the enriched\n", + "# consolidated RDS + per-method regional / significant-QTL / event / summary\n", + "# tables). Replaces the old source(pecotmr/inst/code/tensorqtl_postprocessor.R).\n", + "output: f\"{output_dir:a}/{cwd:b}.qtl_association_postprocessing.rds\"\n", + "bash: expand = \"${ }\"\n", + " Rscript ${modular_script_dir:a}/pecotmr_integration/qtl_association_postprocessing.R \\\n", + " --cwd ${work_dir:a} \\\n", + " --regional-pattern \"${regional_pattern}\" \\\n", + " --qtl-pattern \"${qtl_pattern}\" \\\n", + " --n-variants-suffix \"${n_variants_suffix}\" \\\n", + " --maf-cutoff ${maf_cutoff} --cis-window ${cis_window} \\\n", + " --fdr-threshold ${fdr_threshold} --pvalue-cutoff ${pvalue_cutoff} \\\n", + " --pvalue-col \"${pvalue_col}\" --af-col \"${af_col}\" \\\n", + " --study \"${study}\" --context \"${context}\" --genome \"${genome}\" \\\n", + " --output ${_output:a} --output-dir ${output_dir:a}\n" ] } ], diff --git a/code/SoS/mnm_analysis/mnm_methods/mnm_regression.ipynb b/code/SoS/mnm_analysis/mnm_methods/mnm_regression.ipynb index c708539b0..ad326982f 100644 --- a/code/SoS/mnm_analysis/mnm_methods/mnm_regression.ipynb +++ b/code/SoS/mnm_analysis/mnm_methods/mnm_regression.ipynb @@ -313,7 +313,7 @@ "source": [ "### Multivariate analysis: mvSuSiE and mr.mash (`mnm`)\n", "\n", - "Fine-maps multiple molecular phenotypes jointly across a shared window using mvSuSiE with mr.mash priors. This step needs **multiple contexts** (e.g. the same genes measured under two or more conditions). The toy set ships a single context, so for this MWE we add a **second, synthetic context** (`example/colocboost_ctx2.bed.gz`, derived from context 1 with added noise — *demo data only, not a real measurement*) and a multi-context phenotype manifest. With that in place the `mnm` step now runs end-to-end on the toy data and produces `multicontext_bvsr.rds`, `multicontext_twas_weights.rds`, and `multicontext_data.rds` per gene." + "Fine-maps multiple molecular phenotypes jointly across a shared window using mvSuSiE with mr.mash priors. This step needs **multiple contexts** (e.g. the same genes measured under two or more conditions). The toy set ships a single context, so for this MWE we add a **second, synthetic context** (`example/colocboost_ctx2.bed.gz`, derived from context 1 with added noise \u2014 *demo data only, not a real measurement*) and a multi-context phenotype manifest. With that in place the `mnm` step now runs end-to-end on the toy data and produces `multicontext_bvsr.rds`, `multicontext_twas_weights.rds`, and `multicontext_data.rds` per gene." ] }, { @@ -578,60 +578,7 @@ " raise ValueError(f\"``skip_analysis_pip_cutoff`` should have either length 1 or length the same as phenotype files ({len(phenoFile)} in this case)\")\n", "\n", "# make it into an R List string\n", - "skip_analysis_pip_cutoff = [f\"'{y}'={x}\" for x,y in zip(skip_analysis_pip_cutoff, phenotype_names)]\n", - " \n", - "def group_by_region(lst, partition):\n", - " # from itertools import accumulate\n", - " # partition = [len(x) for x in partition]\n", - " # Compute the cumulative sums once\n", - " # cumsum_vector = list(accumulate(partition))\n", - " # Use slicing based on the cumulative sums\n", - " # return [lst[(cumsum_vector[i-1] if i > 0 else 0):cumsum_vector[i]] for i in range(len(partition))]\n", - " return partition\n", - "\n", - "import os\n", - "import pandas as pd\n", - "\n", - "def adapt_file_path(file_path, reference_file):\n", - " \"\"\"\n", - " Adapt a single file path based on its existence and a reference file's path.\n", - "\n", - " Args:\n", - " - file_path (str): The file path to adapt.\n", - " - reference_file (str): File path to use as a reference for adaptation.\n", - "\n", - " Returns:\n", - " - str: Adapted file path.\n", - "\n", - " Raises:\n", - " - FileNotFoundError: If no valid file path is found.\n", - " \"\"\"\n", - " reference_path = os.path.dirname(reference_file)\n", - "\n", - " # Check if the file exists\n", - " if os.path.isfile(file_path):\n", - " return file_path\n", - "\n", - " # Check file name without path\n", - " file_name = os.path.basename(file_path)\n", - " if os.path.isfile(file_name):\n", - " return file_name\n", - "\n", - " # Check file name in reference file's directory\n", - " file_in_ref_dir = os.path.join(reference_path, file_name)\n", - " if os.path.isfile(file_in_ref_dir):\n", - " return file_in_ref_dir\n", - "\n", - " # Check original file path prefixed with reference file's directory\n", - " file_prefixed = os.path.join(reference_path, file_path)\n", - " if os.path.isfile(file_prefixed):\n", - " return file_prefixed\n", - "\n", - " # If all checks fail, raise an error\n", - " raise FileNotFoundError(f\"No valid path found for file: {file_path}\")\n", - "\n", - "def adapt_file_path_all(df, column_name, reference_file):\n", - " return df[column_name].apply(lambda x: adapt_file_path(x, reference_file))" + "skip_analysis_pip_cutoff = [f\"'{y}'={x}\" for x,y in zip(skip_analysis_pip_cutoff, phenotype_names)]\n" ] }, { @@ -718,8 +665,10 @@ "# Fine-mapping SER pre-screen (0 = off, <0 = adaptive 3/nVariants).\n", "parameter: pip_cutoff_to_skip = 0.0\n", "# TWAS weight-learning knobs.\n", - "parameter: min_twas_maf = 0.01\n", - "parameter: min_twas_xvar = 0.01\n", + "# TWAS learns weights applied out-of-sample; keep an explicit MAF / X-variance\n", + "# cutoff for the TWAS pass (passed via the shared --maf-cutoff/--xvar-cutoff).\n", + "parameter: twas_maf_cutoff = 0.01\n", + "parameter: twas_xvar_cutoff = 0.01\n", "parameter: max_cv_variants = 5000\n", "parameter: cv_folds = 5\n", "parameter: cv_threads = 1\n", @@ -743,15 +692,25 @@ "qtl_dataset = path(f\"{cwd:a}/qtl_dataset/{name}.qtl_dataset.rds\")\n", "# Assemble the shared opt-in worker flags once (command construction only).\n", "seed_arg = f\"--seed {seed}\" if seed >= 0 else \"\"\n", + "# Non-MAF/xvar filters are shared by both passes (empty = use the dataset slots).\n", "filter_overrides = \" \".join(filter(None, [\n", - " f\"--maf-cutoff {maf_cutoff}\" if maf_cutoff >= 0 else \"\",\n", " f\"--mac-cutoff {mac_cutoff}\" if mac_cutoff >= 0 else \"\",\n", - " f\"--xvar-cutoff {xvar_cutoff}\" if xvar_cutoff >= 0 else \"\",\n", " f\"--imiss-cutoff {imiss_cutoff}\" if imiss_cutoff >= 0 else \"\",\n", " \"--drop-indel\" if drop_indel else \"\",\n", " f\"--keep-samples {keep_samples}\" if keep_samples != \".\" else \"\",\n", " f\"--keep-variants {keep_variants}\" if keep_variants != \".\" else \"\",\n", "]))\n", + "# MAF / X-variance ride the shared --maf-cutoff/--xvar-cutoff, handled per pass:\n", + "# fine-mapping opt-in only (default off = dataset slot); TWAS always explicit\n", + "# (its portability cutoff) unless a general override is set, which wins for both.\n", + "fm_maf_xvar = \" \".join(filter(None, [\n", + " f\"--maf-cutoff {maf_cutoff}\" if maf_cutoff >= 0 else \"\",\n", + " f\"--xvar-cutoff {xvar_cutoff}\" if xvar_cutoff >= 0 else \"\",\n", + "]))\n", + "twas_maf_xvar = \" \".join([\n", + " f\"--maf-cutoff {maf_cutoff if maf_cutoff >= 0 else twas_maf_cutoff}\",\n", + " f\"--xvar-cutoff {xvar_cutoff if xvar_cutoff >= 0 else twas_xvar_cutoff}\",\n", + "])\n", "input: qtl_dataset, for_each = \"region_name\"\n", "output: fine_mapping = f\"{cwd:a}/fine_mapping/{name}.{_region_name}.univariate_bvsr.rds\",\n", " twas_weights = f\"{cwd:a}/twas_weights/{name}.{_region_name}.univariate_twas_weights.rds\"\n", @@ -764,7 +723,7 @@ " --methods ${fine_mapping_methods} \\\n", " --coverage ${fine_mapping_coverage} \\\n", " --pip-cutoff-to-skip ${pip_cutoff_to_skip} \\\n", - " ${seed_arg} ${filter_overrides} \\\n", + " ${seed_arg} ${filter_overrides} ${fm_maf_xvar} \\\n", " ${(\"--contexts \" + contexts) if contexts else \"\"} \\\n", " ${(\"--method-args '\" + fine_mapping_method_args + \"'\") if fine_mapping_method_args else \"\"} \\\n", " --output ${_output[\"fine_mapping\"]}\n", @@ -774,13 +733,11 @@ " --gene-id ${_region_name} \\\n", " --cis-window ${cis_window} \\\n", " --methods ${twas_methods} \\\n", - " --min-twas-maf ${min_twas_maf} \\\n", - " --min-twas-xvar ${min_twas_xvar} \\\n", " --max-cv-variants ${max_cv_variants} \\\n", " --cv-folds ${cv_folds} \\\n", " --cv-threads ${cv_threads} \\\n", " --fine-mapping-result ${_output[\"fine_mapping\"]} \\\n", - " ${seed_arg} ${filter_overrides} \\\n", + " ${seed_arg} ${filter_overrides} ${twas_maf_xvar} \\\n", " ${(\"--contexts \" + contexts) if contexts else \"\"} \\\n", " ${(\"--method-args '\" + twas_method_args + \"'\") if twas_method_args else \"\"} \\\n", " --output ${_output[\"twas_weights\"]}" @@ -994,7 +951,7 @@ "stop_if(len(regional_data['data']) == 0, f'Either genotype or phenotype data are not available for region {\", \".join(region_name)}.')\n", "\n", "meta_info = regional_data['meta_info']\n", - "input: regional_data[\"data\"], group_by = lambda x: group_by_region(x, regional_data[\"data\"]), group_with = \"meta_info\"\n", + "input: regional_data[\"data\"], group_by = lambda x: regional_data[\"data\"], group_with = \"meta_info\"\n", "output: f'{cwd:a}/{step_name[:-2]}/{name}.{_meta_info[0]}.mvfsusie_{prior}.rds'\n", "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", "R: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container, entrypoint = entrypoint\n", diff --git a/code/SoS/mnm_analysis/mnm_postprocessing.ipynb b/code/SoS/mnm_analysis/mnm_postprocessing.ipynb index 79929fc3f..e5d425377 100644 --- a/code/SoS/mnm_analysis/mnm_postprocessing.ipynb +++ b/code/SoS/mnm_analysis/mnm_postprocessing.ipynb @@ -207,8 +207,6 @@ "outputs": [], "source": [ "[global]\n", - "import glob\n", - "import pandas as pd\n", "# A region list file documenting the chr_pos_ref_alt of a susie_object\n", "parameter: cwd = path(\"output\")\n", "parameter: study = str\n", @@ -217,6 +215,9 @@ "## Path to work directory where output locates\n", "## Containers that contains the necessary packages\n", "parameter: container = \"\"\n", + "import re\n", + "parameter: modular_script_dir = path('code/script') # override with --modular-script-dir\n", + "parameter: entrypoint= ('micromamba run -a \"\" -n' + ' ' + re.sub(r'(_apptainer:latest|_docker:latest|\\.sif)$', '', container.split('/')[-1])) if container else \"\"\n", "# For cluster jobs, number commands to run per job\n", "parameter: job_size = 1\n", "# Wall clock time expected\n", @@ -240,93 +241,23 @@ "outputs": [], "source": [ "[susie_to_tsv_1]\n", - "# Input\n", - "# For complete susie, region_list or tad_list, for susie_rss , LD region list \n", - "parameter: region_list = path\n", - "region_tbl = pd.read_csv(region_list,sep = \"\\t\")\n", + "# Migrated: consumes a FineMappingResult RDS (fine_mapping.R output) instead of a\n", + "# raw susieR object. The three legacy outputs map to fine_mapping_export.R views:\n", + "# variant.tsv = topLoci (per-variant: pip, posterior mean/sd, logBF, cs, region)\n", + "# lbf.tsv = lbf (wide per-variant x per-effect log Bayes factor matrix)\n", + "# effect.tsv = cs_summary (per credible set: size, purity, V, logBF, lead variant)\n", + "# The FineMappingResult carries its own region/trait, so `region_list` is accepted\n", + "# for CLI compatibility but is no longer used.\n", + "parameter: region_list = path()\n", "parameter: rds_path = paths\n", "input: rds_path, group_by = 1\n", - "output: f\"{cwd}/{_input:bn}.variant.tsv\",f\"{cwd}/{_input:bn}.lbf.tsv\",f\"{cwd}/{_input:bn}.effect.tsv\"\n", + "output: f\"{cwd}/{_input:bn}.variant.tsv\", f\"{cwd}/{_input:bn}.lbf.tsv\", f\"{cwd}/{_input:bn}.effect.tsv\"\n", "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output[0]:bn}'\n", - "R: expand = '${ }', stdout = f\"{_output[0]:nn}.stdout\", stderr = f\"{_output[0]:nn}.stderr\", container = container\n", - " library(\"dplyr\")\n", - " library(\"tibble\")\n", - " library(\"purrr\")\n", - " library(\"tidyr\")\n", - " library(\"readr\")\n", - " library(\"stringr\")\n", - " library(\"susieR\")\n", - " extract_lbf = function(susie_obj){\n", - " \n", - " if(\"variants\" %in% names(susie_obj) ){\n", - " ss_bf = tibble(snps = susie_obj$variants, cs_index = ifelse(is.null(susie_obj$sets$cs_index), 0, paste0(susie_obj$sets$cs_index,collapse =\",\")),names = \"${f'{_input:br}'.split('.')[-4]}\")\n", - " }\n", - " else \n", - " {\n", - " ss_bf = tibble(snps = susie_obj$variable_name, cs_index = ifelse(is.null(susie_obj$sets$cs_index), 0, paste0(susie_obj$sets$cs_index,collapse =\",\")),names = \"${_input:bnnn}\")\n", - " }\n", - " \n", - " ss_bf = ss_bf%>%cbind(susie_obj$lbf_variable%>%t)%>%as_tibble()\n", - " \n", - " return(ss_bf)\n", - " }\n", - " \n", - " extract_variants_pip = function(susie_obj,region_list){\n", - " susie_tb = tibble( variants = names(susie_obj$pip)[which( susie_obj$pip >= 0)],\n", - " snps_index = which(( susie_obj$pip >= 0))) %>%\n", - " mutate(chromosome = map_chr(variants, ~read.table(text = .x, sep = \":\")$V1%>%str_replace(\"chr\",\"\") ),\n", - " position = map_chr(variants, ~read.table(text = .x, sep = \":\")$V2 ),\n", - " ref = map_chr(position , ~read.table(text = .x, sep = \"_\",colClasses = \"character\")$V2 ),\n", - " alt = map_chr(position , ~read.table(text = .x, sep = \"_\",colClasses = \"character\")$V3 ),\n", - " position = map_dbl(position , ~read.table(text = .x, sep = \"_\",as.is = T)$V1 )\n", - " )\n", - " susie_tb = susie_tb%>%mutate(cs_order =(map(susie_tb$snps_index , ~tryCatch(which(pmap(list( a= susie_obj$sets$cs) , function(a) .x %in% a )%>%unlist()), error = function(e) return(0) ) ))%>%as.character%>%str_replace(\"integer\\\\(0\\\\)\",\"0\"),\n", - " cs_id = map_chr(cs_order,~ifelse(.x ==\"0\", \"None\" ,names(susie_obj$sets$cs)[.x%>%str_split(\":\")%>%unlist%>%as.numeric] ) ),\n", - " log10_base_factor = map_chr(snps_index,~paste0( susie_obj$lbf_variable[,.x], collapse = \";\")),\n", - " pip = susie_obj$pip,\n", - " posterior_mean = coef.susie(susie_obj)[-1],\n", - " posterior_sd = susie_get_posterior_sd(susie_obj),\n", - " z = posterior_mean/posterior_sd)\n", - " \n", - " susie_tb = susie_tb%>%mutate( molecular_trait_id = region_list$molecular_trait_id,\n", - " finemapped_region_start = region_list$finemapped_region_start,\n", - " finemapped_region_end = region_list$finemapped_region_end)\n", - " return(susie_tb) }\n", - " \n", - " \n", - "\n", - " extract_effect_pip = function(susie_obj,region_list,susie_tb){\n", - " result_tb = tibble(phenotype = susie_obj$name,\n", - " V = susie_obj$V,effect_id = paste0(\"L\",1:length(V) ) ,\n", - " cs_log10bf = susie_obj$lbf)\n", - " if(is.null(susie_obj$sets$cs)){\n", - " cs_min_r2 = cs_avg_r2 = coverage = 0 \n", - " cs = \"None\"} else { cs = map_chr(susie_obj$sets$cs[result_tb$effect_id],~susie_tb$variants[.x]%>%paste0(collapse = \";\"))\n", - " coverage = map(result_tb$effect_id, ~susie_obj$sets$coverage[which(names(susie_obj$sets$cs) == .x )])%>%as.numeric%>%replace_na(0)\n", - " cs_min_r2 = (susie_obj$sets$purity[result_tb$effect_id,1])%>%as.numeric%>%replace_na(0) \n", - " cs_avg_r2 = (susie_obj$sets$purity[result_tb$effect_id,2])%>%as.numeric%>%replace_na(0) }\n", - " result_tb = result_tb%>%mutate(cs_min_r2 = cs_min_r2,cs_avg_r2 = cs_avg_r2 ,coverage = coverage%>%unlist,cs = cs ) \n", - " return(result_tb)\n", - " }\n", - " \n", - " \n", - " susie_obj = readRDS(\"${_input:a}\")\n", - " if(\"variants\" %in% names(susie_obj) ){susie_obj$variants = susie_obj$variants%>%str_replace(\"_\",\":\")}\n", - " if(is.null(names(susie_obj$pip ))){names(susie_obj$pip) = susie_obj$variants}\n", - " lbf = extract_lbf(susie_obj)\n", - " region_list = read_delim(\"${region_list}\",\"\\t\")\n", - " if(ncol(region_list) == 3 ){ region_list = region_list%>%mutate(`#chr` = `#chr`%>%str_remove_all(\" \") , ID = paste0(`#chr`,\"_\",start,\"_\",end) ) } # LD_list \n", - " if(region_list$start[1] - region_list$end[1] == -1 ){ \n", - " region_list = region_list%>%mutate( start = start - ${windows} ,end = start +${windows}) # region_list for fix cis windows \n", - " } \n", - " if(\"gene_id\" %in% colnames(region_list)){region_list = region_list%>%mutate(ID = gene_id) } # region_list for gene\n", - " region_list = region_list%>%select(molecular_trait_id = ID, chromosome = `#chr`,finemapped_region_start = start ,finemapped_region_end = end) # Formatting\n", - " region_list = region_list%>%filter(molecular_trait_id == \"${f'{_input:br}'.split('.')[-4]}\")\n", - " variants_pip = extract_variants_pip( susie_obj , region_list)\n", - " effect_pip = extract_effect_pip( susie_obj , region_list,variants_pip)\n", - " lbf%>%write_delim(\"${_output[1]}\",\"\\t\")\n", - " variants_pip%>%write_delim(\"${_output[0]}\",\"\\t\")\n", - " effect_pip%>%write_delim(\"${_output[2]}\",\"\\t\")" + "bash: expand = '${ }', stdout = f\"{_output[0]:nn}.stdout\", stderr = f\"{_output[0]:nn}.stderr\", container = container, entrypoint = entrypoint\n", + " export_script=${modular_script_dir}/pecotmr_integration/fine_mapping_export.R\n", + " Rscript $export_script --input ${_input} --view topLoci --signal-cutoff 0 --output ${_output[0]}\n", + " Rscript $export_script --input ${_input} --view lbf --output ${_output[1]}\n", + " Rscript $export_script --input ${_input} --view cs_summary --output ${_output[2]}" ] }, { @@ -339,98 +270,22 @@ "outputs": [], "source": [ "[sQTL_susie_to_tsv_1]\n", - "# Input\n", - "# For complete susie, region_list or tad_list, for susie_rss , LD region list \n", - "parameter: region_list = path\n", - "region_tbl = pd.read_csv(region_list,sep = \"\\t\")\n", + "# Migrated: identical to susie_to_tsv but preserves the sQTL / leafcutter2\n", + "# filename sanitization (\"*\" -> \"N\"; \":\"/\"+\" scrubbed from the task tag), since\n", + "# intron ids contain shell-hostile characters. Consumes a FineMappingResult RDS\n", + "# and writes the topLoci / lbf / cs_summary views.\n", + "parameter: region_list = path()\n", "parameter: rds_path = paths\n", "input: rds_path, group_by = 1\n", - "input_name=f\"{_input:bn}\"\n", - "input_name=input_name.replace('*', 'N') # \"*\" in leafcutter2 would be ignored in shell and cause error \n", - "output: f\"{cwd}/{input_name}.variant.tsv\",f\"{cwd}/{input_name}.lbf.tsv\",f\"{cwd}/{input_name}.effect.tsv\"\n", - "tags = f'{step_name}_{_output[0]:bn}'\n", - "tags = tags.replace(':', '_').replace('+', 'ps') # also for other symbols in tag id \n", + "input_name = f\"{_input:bn}\".replace('*', 'N')\n", + "output: f\"{cwd}/{input_name}.variant.tsv\", f\"{cwd}/{input_name}.lbf.tsv\", f\"{cwd}/{input_name}.effect.tsv\"\n", + "tags = f'{step_name}_{_output[0]:bn}'.replace(':', '_').replace('+', 'ps')\n", "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = tags\n", - "R: expand = '${ }', stdout = f\"{_output[0]:nn}.stdout\", stderr = f\"{_output[0]:nn}.stderr\", container = container\n", - " library(\"dplyr\")\n", - " library(\"tibble\")\n", - " library(\"purrr\")\n", - " library(\"tidyr\")\n", - " library(\"readr\")\n", - " library(\"stringr\")\n", - " library(\"susieR\")\n", - " extract_lbf = function(susie_obj){\n", - " \n", - " if(\"variants\" %in% names(susie_obj) ){\n", - " ss_bf = tibble(snps = susie_obj$variants, cs_index = ifelse(is.null(susie_obj$sets$cs_index), 0, paste0(susie_obj$sets$cs_index,collapse =\",\")),names = \"${f'{_input:br}'.split('.')[-4]}\")\n", - " }\n", - " else \n", - " {\n", - " ss_bf = tibble(snps = susie_obj$variable_name, cs_index = ifelse(is.null(susie_obj$sets$cs_index), 0, paste0(susie_obj$sets$cs_index,collapse =\",\")),names = \"${_input:bnnn}\")\n", - " }\n", - " \n", - " ss_bf = ss_bf%>%cbind(susie_obj$lbf_variable%>%t)%>%as_tibble()\n", - " \n", - " return(ss_bf)\n", - " }\n", - " \n", - " extract_variants_pip = function(susie_obj,region_list){\n", - " susie_tb = tibble( variants = names(susie_obj$pip)[which( susie_obj$pip >= 0)],\n", - " snps_index = which(( susie_obj$pip >= 0))) %>%\n", - " mutate(chromosome = map_chr(variants, ~read.table(text = .x, sep = \":\")$V1%>%str_replace(\"chr\",\"\") ),\n", - " position = map_chr(variants, ~read.table(text = .x, sep = \":\")$V2 ),\n", - " ref = map_chr(position , ~read.table(text = .x, sep = \"_\",colClasses = \"character\")$V2 ),\n", - " alt = map_chr(position , ~read.table(text = .x, sep = \"_\",colClasses = \"character\")$V3 ),\n", - " position = map_dbl(position , ~read.table(text = .x, sep = \"_\",as.is = T)$V1 )\n", - " )\n", - " susie_tb = susie_tb%>%mutate(cs_order =(map(susie_tb$snps_index , ~tryCatch(which(pmap(list( a= susie_obj$sets$cs) , function(a) .x %in% a )%>%unlist()), error = function(e) return(0) ) ))%>%as.character%>%str_replace(\"integer\\\\(0\\\\)\",\"0\"),\n", - " cs_id = map_chr(cs_order,~ifelse(.x ==\"0\", \"None\" ,names(susie_obj$sets$cs)[.x%>%str_split(\":\")%>%unlist%>%as.numeric] ) ),\n", - " log10_base_factor = map_chr(snps_index,~paste0( susie_obj$lbf_variable[,.x], collapse = \";\")),\n", - " pip = susie_obj$pip,\n", - " posterior_mean = coef.susie(susie_obj)[-1],\n", - " posterior_sd = susie_get_posterior_sd(susie_obj),\n", - " z = posterior_mean/posterior_sd)\n", - " \n", - " susie_tb = susie_tb%>%mutate( molecular_trait_id = region_list$molecular_trait_id,\n", - " finemapped_region_start = region_list$finemapped_region_start,\n", - " finemapped_region_end = region_list$finemapped_region_end)\n", - " return(susie_tb) }\n", - " \n", - " \n", - "\n", - " extract_effect_pip = function(susie_obj,region_list,susie_tb){\n", - " result_tb = tibble(phenotype = susie_obj$name,\n", - " V = susie_obj$V,effect_id = paste0(\"L\",1:length(V) ) ,\n", - " cs_log10bf = susie_obj$lbf)\n", - " if(is.null(susie_obj$sets$cs)){\n", - " cs_min_r2 = cs_avg_r2 = coverage = 0 \n", - " cs = \"None\"} else { cs = map_chr(susie_obj$sets$cs[result_tb$effect_id],~susie_tb$variants[.x]%>%paste0(collapse = \";\"))\n", - " coverage = map(result_tb$effect_id, ~susie_obj$sets$coverage[which(names(susie_obj$sets$cs) == .x )])%>%as.numeric%>%replace_na(0)\n", - " cs_min_r2 = (susie_obj$sets$purity[result_tb$effect_id,1])%>%as.numeric%>%replace_na(0) \n", - " cs_avg_r2 = (susie_obj$sets$purity[result_tb$effect_id,2])%>%as.numeric%>%replace_na(0) }\n", - " result_tb = result_tb%>%mutate(cs_min_r2 = cs_min_r2,cs_avg_r2 = cs_avg_r2 ,coverage = coverage%>%unlist,cs = cs ) \n", - " return(result_tb)\n", - " }\n", - " \n", - " \n", - " susie_obj = readRDS(\"${_input:a}\")\n", - " if(\"variants\" %in% names(susie_obj) ){susie_obj$variants = susie_obj$variants%>%str_replace(\"_\",\":\")}\n", - " if(is.null(names(susie_obj$pip ))){names(susie_obj$pip) = susie_obj$variants}\n", - " lbf = extract_lbf(susie_obj)\n", - " region_list = read_delim(\"${region_list}\",\"\\t\")\n", - " if(ncol(region_list) == 3 ){ region_list = region_list%>%mutate(`#chr` = `#chr`%>%str_remove_all(\" \") , ID = paste0(`#chr`,\"_\",start,\"_\",end) ) } # LD_list \n", - " if(region_list$start[1] - region_list$end[1] == -1 ){ \n", - " region_list = region_list%>%mutate( start = start - ${windows} ,end = start +${windows}) # region_list for fix cis windows \n", - " } \n", - " if(\"gene_id\" %in% colnames(region_list)){region_list = region_list%>%mutate(ID = gene_id) } # region_list for gene\n", - " region_list = region_list%>%select(molecular_trait_id = ID, chromosome = `#chr`,finemapped_region_start = start ,finemapped_region_end = end) # Formatting\n", - " mole_id = \"${f'{_input:br}'.split('.')[-4]}\"%>%gsub(\"_N:\",\"_*:\",.)#for sQTL\n", - " region_list = region_list%>%filter(molecular_trait_id == mole_id)\n", - " variants_pip = extract_variants_pip( susie_obj , region_list)\n", - " effect_pip = extract_effect_pip( susie_obj , region_list,variants_pip)\n", - " lbf%>%write_delim(\"${_output[1]}\",\"\\t\")\n", - " variants_pip%>%write_delim(\"${_output[0]}\",\"\\t\")\n", - " effect_pip%>%write_delim(\"${_output[2]}\",\"\\t\")" + "bash: expand = '${ }', stdout = f\"{_output[0]:nn}.stdout\", stderr = f\"{_output[0]:nn}.stderr\", container = container, entrypoint = entrypoint\n", + " export_script=${modular_script_dir}/pecotmr_integration/fine_mapping_export.R\n", + " Rscript $export_script --input ${_input} --view topLoci --signal-cutoff 0 --output ${_output[0]}\n", + " Rscript $export_script --input ${_input} --view lbf --output ${_output[1]}\n", + " Rscript $export_script --input ${_input} --view cs_summary --output ${_output[2]}" ] }, { @@ -443,51 +298,22 @@ "outputs": [], "source": [ "[fsusie_to_tsv_1]\n", - "# Input\n", - "# For complete susie, region_list or tad_list, for susie_rss , LD region list \n", - "parameter: region_list = path\n", - "region_tbl = pd.read_csv(region_list,sep = \"\\t\")\n", + "# Migrated: consumes an fSuSiE FineMappingResult RDS.\n", + "# variant.tsv = topLoci (per-variant: pip, cs, cs_95_purity)\n", + "# lbf.tsv = lbf (fSuSiE per-variant x per-effect lBF matrix)\n", + "# (Fixes the legacy bug where lbf.tsv was written the variant table, not the lbf\n", + "# matrix.) is_dummy = cs_95_purity < 0.5; the functional effect curves + peak\n", + "# positions are exported by fsusie_extract_effect / fsusie_affected_region\n", + "# (credible_band / affected_regions views), so they are not duplicated here.\n", + "parameter: region_list = path()\n", "parameter: rds_path = paths\n", "input: rds_path, group_by = 1\n", - "output: f\"{cwd}/{_input:bn}.variant.tsv\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output[0]:bn}'\n", - "R: expand = '${ }', stdout = f\"{_output[0]:nn}.stdout\", stderr = f\"{_output[0]:nn}.stderr\", container = container\n", - " library(\"dplyr\")\n", - " library(\"tibble\")\n", - " library(\"purrr\")\n", - " library(\"tidyr\")\n", - " library(\"readr\")\n", - " library(\"stringr\")\n", - " library(\"susieR\")\n", - "\n", - " extract_variants_pip = function(susie_obj,region_list){\n", - " susie_tb = tibble( variants = names(susie_obj$csd_X),\n", - " snps_index = which(( susie_obj$pip >= 0))) %>%\n", - " mutate(chromosome = map_chr(variants, ~read.table(text = .x, sep = \":\")$V1%>%str_replace(\"chr\",\"\") ),\n", - " position = map_chr(variants, ~read.table(text = .x, sep = \":\")$V2 ),\n", - " ref = map_chr(position , ~read.table(text = .x, sep = \"_\",colClasses = \"character\")$V2 ),\n", - " alt = map_chr(position , ~read.table(text = .x, sep = \"_\",colClasses = \"character\")$V3 ),\n", - " position = map_dbl(position , ~read.table(text = .x, sep = \"_\",as.is = T)$V1 )\n", - " )\n", - " susie_tb = susie_tb%>%mutate(cs_order =(map(susie_tb$snps_index , ~tryCatch(which(pmap(list( a= susie_obj$cs) , function(a) .x %in% a )%>%unlist()), error = function(e) return(0) ) ))%>%as.character%>%str_replace(\"integer\\\\(0\\\\)\",\"0\"),\n", - " pip = susie_obj$pip)\n", - " susie_tb = susie_tb%>%mutate( molecular_trait_id = region_list$tad_index,\n", - " finemapped_region_start = region_list$start,\n", - " finemapped_region_end = region_list$end)\n", - " if(\"purity\" %in% names(susie_obj)){\n", - " susie_tb = susie_tb%>%mutate(purity = map_dbl(susie_tb$cs_order, ~ifelse(.x%>%as.numeric > 0, susie_obj$purity[[as.numeric(.x)]], NA ) ), is_dummy = as.numeric(purity < 0.5) )\n", - " }\n", - " susie_tb = susie_tb%>%mutate(effect_peak_pos = map_dbl(cs_order, ~ifelse(.x%>%as.numeric > 0, susie_obj$outing_grid[which(abs(susie_obj$fitted_func[[as.numeric(.x)]]) == max(abs(susie_obj$fitted_func[[as.numeric(.x)]])))] , NA ) )) \n", - " susie_tb_lbf = cbind(susie_tb%>%select(molecular_trait_id,variants,cs_order),Reduce(cbind, susie_obj$lBF)%>%as.tibble%>%`colnames<-`(1:length(susie_obj$lBF)))\n", - " return(list(susie_tb, susie_tb_lbf)) }\n", - " susie_obj = readRDS(\"${_input:a}\")\n", - " region_list = read_delim(\"${region_list}\",\"\\t\")\n", - " region_list = region_list%>%filter(tad_index == \"${f'{_input:br}'.split('.')[-4]}\")\n", - " variants_pip = extract_variants_pip( susie_obj , region_list)[[1]]\n", - " variants_lbf = extract_variants_pip( susie_obj , region_list)[[2]]\n", - " print(paste0(\"fsusie run time is \", round(susie_obj$runtime[[3]]/60),\"min\"))\n", - " variants_pip%>%write_delim(\"${_output}\",\"\\t\")\n", - " variants_pip%>%write_delim(\"${_output:nn}.lbf.tsv\",\"\\t\")" + "output: f\"{cwd}/{_input:bn}.variant.tsv\", f\"{cwd}/{_input:bn}.lbf.tsv\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output[0]:bn}\"\n", + "bash: expand = \"${ }\", stdout = f\"{_output[0]:nn}.stdout\", stderr = f\"{_output[0]:nn}.stderr\", container = container, entrypoint = entrypoint\n", + " export_script=${modular_script_dir}/pecotmr_integration/fine_mapping_export.R\n", + " Rscript $export_script --input ${_input} --view topLoci --signal-cutoff 0 --output ${_output[0]}\n", + " Rscript $export_script --input ${_input} --view lbf --output ${_output[1]}" ] }, { @@ -500,12 +326,17 @@ "outputs": [], "source": [ "[*_to_tsv_2]\n", + "# Reduce: concatenate the per-region variant tables (the *variant.tsv outputs of\n", + "# the parallel _1 map step) into one file, in R via data.table::rbindlist\n", + "# (fill=TRUE aligns columns). _input carries all of _1's outputs, so keep only\n", + "# the variant tables (not the lbf / effect ones).\n", "parameter: name = f'{_input[0]:b}'.split(\".\")[0]\n", "input: group_by = \"all\"\n", "output: f\"{cwd}/{name}.all_variants.tsv\"\n", - "bash: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container\n", - " head -1 ${_input[0]} > ${_output}\n", - " cat ${_input[0]:d}/*variant.tsv | grep -v cs_order >> ${_output}" + "R: expand = \"${ }\", stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container, entrypoint = entrypoint\n", + " library(data.table)\n", + " files <- Filter(function(f) endsWith(f, \"variant.tsv\"), c(${_input:r,}))\n", + " fwrite(rbindlist(lapply(files, fread), fill = TRUE), ${_output:r}, sep = \"\\t\")" ] }, { @@ -518,15 +349,18 @@ "outputs": [], "source": [ "[susie_tsv_collapse]\n", - "parameter: tsv_path = paths # TSV needs have the name ends with *.chr1_2_3.unisusie(_rss).lbf.tsv\n", - "tsv_list = pd.DataFrame({\"lbf_path\" : [str(x) for x in tsv_path]})\n", - "chromosome = list(set([f'{x.split(\".\")[-5].split(\"_\")[0].replace(\"chr\",\"\")}' for x in tsv_list.lbf_path ])) ## Add chr if there is no chr prefix. This is to accomodata chr XY and M\n", + "# Concatenate the per-region lbf tables (named *.chr__...lbf.tsv)\n", + "# by chromosome. Chromosome split is plain python (no pandas); the concat is R\n", + "# data.table::rbindlist (headers handled by fread; fill=TRUE aligns columns).\n", + "parameter: tsv_path = paths\n", + "chromosome = list(set(str(x).split(\".\")[-5].split(\"_\")[0].replace(\"chr\", \"\") for x in tsv_path))\n", "input: tsv_path, for_each = \"chromosome\"\n", "output: f'{cwd}/{_input[0]:bnnnnnnn}.chr{_chromosome}.unisusie_rss.lbf.tsv'\n", - "bash: expand = '${ }', stdout = f\"{_output}.stdout\", stderr = f\"{_output}.stderr\", container = container\n", - " head -1 ${_input[0]} > ${_output}\n", - " cat ${_input[0]:d}/*.chr${_chromosome}_*lbf.tsv | grep -v cs_index >> ${_output}\n", - " " + "R: expand = \"${ }\", stdout = f\"{_output}.stdout\", stderr = f\"{_output}.stderr\", container = container, entrypoint = entrypoint\n", + " library(data.table)\n", + " files <- list.files(dirname(\"${_input[0]}\"),\n", + " pattern = \"\\\\.chr${_chromosome}_.*lbf\\\\.tsv$\", full.names = TRUE)\n", + " fwrite(rbindlist(lapply(files, fread), fill = TRUE), \"${_output}\", sep = \"\\t\")" ] }, { @@ -539,72 +373,24 @@ "outputs": [], "source": [ "[susie_pip_landscape_plot]\n", - "parameter: plot_list = path\n", + "# Per-region PIP landscape from a FineMappingResult (fine_mapping output).\n", + "# Modernized from the legacy multi-TSV plot: pecotmr does no plotting, so the\n", + "# ggplot lives in fine_mapping_pip_plot.R. (The regulatory/gene annotation\n", + "# overlay is a deferred enhancement; annot_tibble is kept for CLI compat.)\n", + "parameter: rds_path = paths\n", "parameter: annot_tibble = path(\"~/Annotatr_builtin_annotation_tibble.tsv\")\n", - "import pandas as pd\n", - "plot_list = pd.read_csv(plot_list,sep = \"\\t\")\n", - "file_type = plot_list.columns.values.tolist()\n", - "file_type = [x.split(\".\")[0] for x in file_type ]\n", - "plot_list = plot_list.to_dict(\"records\")\n", - "input: plot_list, group_by = len(file_type)\n", - "output: f'{cwd}/{\"_\".join(file_type)}.{str(_input[0]).split(\".\")[-5]}.pip_landscape_plot.rds',f'{cwd}/{\"_\".join(file_type)}.{str(_input[0]).split(\".\")[-5]}.pip_landscape_plot.pdf'\n", - "R: expand = '${ }', stdout = f\"{_output[0]}.stdout\", stderr = f\"{_output[0]}.stderr\", container = container\n", - " library(\"dplyr\")\n", - " library(\"readr\") \n", - " library(\"ggplot2\")\n", - " library(\"purrr\")\n", - " color = c(\"black\", \"dodgerblue2\", \"green4\", \"#6A3D9A\", \n", - " \"#FF7F00\", \"gold1\", \"skyblue2\", \"#FB9A99\", \"palegreen2\",\n", - " \"#CAB2D6\", \"#FDBF6F\", \"gray70\", \"khaki2\", \"maroon\", \"orchid1\",\n", - " \"deeppink1\", \"blue1\", \"steelblue4\", \"darkturquoise\", \"green1\", \n", - " \"yellow4\", \"yellow3\",\"darkorange4\",\"brown\",\"navyblue\",\"#FF0000\",\n", - " \"darkgreen\",\"#FFFF00\",\"purple\",\"#00FF00\",\"pink\",\"#0000FF\",\n", - " \"orange\",\"#FF00FF\",\"cyan\",\"#00FFFF\",\"#FFFFFF\")\n", - " extract_table = function(variant_df,type){ \n", - " if(\"purity\" %in% colnames(variant_df) ){\n", - " variant_df$purity[is.na(variant_df$purity)] = 0\n", - " variant_df[abs(variant_df$purity) < 0.5,7] = 0\n", - " }\n", - " variant_df = variant_df%>%mutate(CS = (cs_order%>%as.factor%>%as.numeric-1)%>%as.factor)%>%\n", - " select( y = pip ,snp = variants,pos = position , CS, molecular_trait_id)%>%mutate(molecular_trait_id = paste0(type,\"_\",molecular_trait_id ) )\n", - " return(variant_df)\n", - " }\n", - " plot_recipe = tibble( type = c('${\"','\".join(file_type) }'), path = c(${_input:r,}))\n", - " plot_list = map2(plot_recipe$type,plot_recipe$path, ~read_delim(.y, guess_max = 10000000)%>%extract_table(.x) )\n", - " plot_df = Reduce(rbind,plot_list)\n", - " plot_range = (plot_df%>%group_by(molecular_trait_id)%>%summarize(start = (min(pos)), end = (max(pos)))%>%mutate(start = median(start),end = median(end)))[1,c(2,3)]%>%as.matrix\n", - " plot_chr = (plot_df$snp[1]%>%stringr::str_split(\":\"))[[1]][1]\n", - " plot_df = plot_df%>%mutate(Shared = as.logical(map(snp, ~(plot_df%>%filter( snp ==.x , CS%>%as.numeric != 1 )%>%nrow()) > 1 )))\n", - " pip_plot <- plot_df%>%ggplot2::ggplot(aes(y = y, x = pos,\n", - " col = CS, shape = Shared )) + facet_grid(molecular_trait_id ~.)+\n", - " geom_point(size = 7) +\n", - " scale_color_manual(\"CS\",values = color) +\n", - " theme(axis.ticks.x = element_blank()) +\n", - " ylab(\"Posterior Inclusion Probability (PIP)\")+xlim(plot_range)+\n", - " theme(axis.ticks.x = element_blank()) +\n", - " theme(strip.text.y.right = element_text(angle = 0))+\n", - " xlab(\"\") + \n", - " theme(text = element_text(size = 30))+ggtitle(\"Overview of fine-mapping\")\n", - " \n", - " annot = read_delim(\"${annot_tibble}\")\n", - " annot = annot%>%filter(seqnames == plot_chr, start > plot_range[1], end < plot_range[2])\n", - " annot_plot = annot%>%filter(!type%in%c(\"hg38_genes_introns\",\"hg38_genes_1to5kb\"))%>%\n", - " ggplot(aes())+\n", - " geom_segment( aes(x = start,xend = end, y = \"Regulartory Element\", yend = \"Regulartory Element\", color = type ), linewidth =10)+\n", - " ylab(\"\")+xlab(\"\")+xlim(plot_range)+theme(axis.text.x=element_blank(),text = element_text(size = 20))+scale_color_brewer(palette=\"Dark2\")\n", - " gene_plot = annot%>%filter(type%in%c(\"hg38_genes_1to5kb\"))%>%group_by(symbol)%>%\n", - " summarise(start = min(start), end = max(end))%>%na.omit%>%\n", - " ggplot(aes())+geom_segment( aes(x = start,xend = end, y = \"Gene\", yend = \"Gene\", color = symbol ), linewidth =10)+\n", - " geom_label(aes(x = (start+end)/2,y = \"Gene\", label = symbol ),size = 5)+ylab(\"\")+xlab(\"POS\")+\n", - " theme(legend.position=\"none\")+theme(text = element_text(size = 20))+xlim(plot_range)\n", - " \n", - " list(pip_plot,plot_df,annot_plot,gene_plot)%>%saveRDS(\"${_output[0]}\")\n", - " cowplot::plot_grid(plotlist = list(pip_plot,annot_plot,gene_plot),ncol = 1, align = \"v\",axis = \"tlbr\",rel_heights = c(8,1,1))%>%ggsave(filename = \"${_output[1]}\",device = \"pdf\",dpi = \"retina\",width = 30, height = 30)" + "input: rds_path, group_by = 1\n", + "output: f'{cwd}/{_input:bn}.pip_landscape_plot.pdf'\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container, entrypoint = entrypoint\n", + " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_pip_plot.R \\\n", + " --input ${_input} \\\n", + " --output ${_output}\n" ] }, { "cell_type": "code", - "execution_count": 1, + "execution_count": null, "id": "juvenile-leone", "metadata": { "kernel": "SoS" @@ -612,34 +398,17 @@ "outputs": [], "source": [ "[susie_upsetR_plot]\n", - "parameter: plot_list = path\n", - "import pandas as pd\n", - "plot_list = pd.read_csv(plot_list, sep = \"\\t\")\n", - "file_type = plot_list.columns.values.tolist()\n", - "file_type = [x.split(\".\")[0] for x in file_type ]\n", - "plot_list = plot_list.to_dict(\"records\")\n", - "input: plot_list\n", - "output: f'{cwd}/{\"_\".join(file_type)}.UpSetR.rds',f'{cwd}/{\"_\".join(file_type)}.UpSetR.pdf'\n", - "R: expand = '${ }', stdout = f\"{_output[0]}.stdout\", stderr = f\"{_output[0]}.stderr\", container = container\n", - " library(\"dplyr\")\n", - " library(\"readr\") \n", - " library(\"ggplot2\")\n", - " library(\"purrr\")\n", - " library(\"UpSetR\")\n", - " library(\"ComplexUpset\")\n", - " plot_recipe = tibble( type = c('${\"','\".join(file_type) }'), path = c(${_input:r,}))\n", - " plot_list = map2(plot_recipe$type,plot_recipe$path, ~read_delim(.y, guess_max = 10000000)%>%mutate(cs = cs_order != 0 )%>%filter(cs > 0)%>%select(variants,cs)%>%`colnames<-`(c(\"variants\",.x))%>%distinct() )\n", - " cs_sharing = Reduce(full_join,plot_list)\n", - " cs_upsetR_sharing = cs_sharing\n", - " cs_upsetR_sharing[,2:ncol(cs_upsetR_sharing)]%>%mutate_all(as.numeric)-> cs_upsetR_sharing[,2:ncol(cs_upsetR_sharing)]\n", - " a = upset(cs_upsetR_sharing%>%as.data.frame,intersect = colnames(cs_upsetR_sharing[2:ncol(cs_upsetR_sharing)]),\n", - " keep_empty_groups = F,\n", - " base_annotations=list(`Intersection size` = intersection_size( bar_number_threshold = 1, position = position_dodge(0.5), width = 0.3 ,text = list(size = 5) ) ) ,\n", - " themes=upset_default_themes(axis.text=element_text(size=30)) ,\n", - " min_degree = 1)\n", - " \n", - " a%>%ggsave(filename = \"${_output[1]}\",device = \"pdf\",dpi = \"retina\",width=18.5, height=10.5)\n", - " list(cs_upsetR_sharing)%>%saveRDS(\"${_output[0]}\")" + "# UpSet plot of credible-set variant overlap across the FineMappingResult(s)'\n", + "# (study, context, trait, method) tuples. pecotmr does no plotting; the UpSet\n", + "# lives in fine_mapping_upset.R.\n", + "parameter: rds_path = paths\n", + "input: rds_path\n", + "output: f'{cwd}/{name}.UpSetR.pdf'\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container, entrypoint = entrypoint\n", + " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_upset.R \\\n", + " --input ${\" \".join([str(x) for x in _input])} \\\n", + " --output ${_output}\n" ] }, { @@ -652,50 +421,19 @@ "outputs": [], "source": [ "[susie_upsetR_cs_plot]\n", - "parameter: plot_list = path\n", - "import pandas as pd\n", - "plot_list = pd.read_csv(plot_list, sep = \"\\t\")\n", - "file_type = plot_list.columns.values.tolist()\n", - "file_type = [x.split(\".\")[0] for x in file_type ]\n", - "plot_list = plot_list.to_dict(\"records\")\n", - "parameter: trait_to_select = 1 \n", - "input: plot_list\n", - "output: f'{cwd}/{\"_\".join(file_type)}.UpSetR_{file_type[trait_to_select-1]}_cs.rds',f'{cwd}/{\"_\".join(file_type)}.UpSetR_{file_type[trait_to_select-1]}_cs.pdf'\n", - "R: expand = '${ }', stdout = f\"{_output[0]}.stdout\", stderr = f\"{_output[0]}.stderr\", container = container\n", - "\n", - " library(\"dplyr\")\n", - " library(\"readr\") \n", - " library(\"ggplot2\")\n", - " library(\"purrr\")\n", - " library(\"UpSetR\")\n", - " library(\"ComplexUpset\")\n", - "\n", - " cs_sharing_identifer = function(upsetR_input,df){\n", - " inner_join(upsetR_input, df%>%select(variants,molecular_trait_id, cs_order)%>%filter(cs_order != 0))%>%select(-variants)-> dfL_CS_sharing\n", - " dfL_CS_sharing[is.na(dfL_CS_sharing)] = FALSE\n", - " dfL_CS_sharing = dfL_CS_sharing%>%group_by(molecular_trait_id,cs_order)%>%summarize(across(everything(), list(mean)) )\n", - " dfL_CS_sharing = dfL_CS_sharing%>%mutate(across(colnames(dfL_CS_sharing)[3:ncol(dfL_CS_sharing)], ~.x != 0 ))%>%`colnames<-`(c(\"molecular_trait_id\",\"cs_order\",colnames(cs_sharing)[2:ncol(cs_sharing)]))\n", - " }\n", - " \n", - " \n", - " plot_recipe = tibble( type = c('${\"','\".join(file_type) }'), path = c(${_input:r,}))\n", - " plot_list = map2(plot_recipe$type,plot_recipe$path, ~read_delim(.y, guess_max = 10000000)%>%mutate(cs = cs_order != 0 )%>%filter(cs > 0)%>%select(variants,cs)%>%`colnames<-`(c(\"variants\",.x))%>%distinct() )\n", - " cs_sharing = Reduce(full_join,plot_list)\n", - " cs_upsetR_sharing = cs_sharing\n", - " cs_upsetR_sharing[,2:ncol(cs_upsetR_sharing)]%>%mutate_all(as.numeric)-> cs_upsetR_sharing[,2:ncol(cs_upsetR_sharing)]\n", - "\n", - " df = read_delim(plot_recipe$path[[${trait_to_select}]]) \n", - " \n", - " cs_sharing_df = cs_sharing_identifer(cs_upsetR_sharing,df)\n", - "\n", - " a = upset(cs_sharing_df%>%as.data.frame,intersect = colnames(cs_sharing_df[3:ncol(cs_sharing_df)]),\n", - " keep_empty_groups = F,\n", - " base_annotations=list(`Intersection size` = intersection_size( bar_number_threshold = 1, position = position_dodge(0.5), width = 0.3 ,text = list(size = 8) ) ),\n", - " themes=upset_default_themes(axis.text=element_text(size=30)),\n", - " set_size = F , min_degree = 1,wrap = T) + ggtitle( paste0(plot_recipe$type[[${trait_to_select}]],'CS shared with other phenotypes') ) + theme(plot.title = element_text(size = 40, face = \"bold\"))\n", - " \n", - " a%>%ggsave(filename = \"${_output[1]}\",device = \"pdf\",dpi = \"retina\",width=18.5, height=10.5)\n", - " list(cs_sharing_df)%>%saveRDS(\"${_output[0]}\")" + "# Credible-set overlap UpSet plot across the FineMappingResult(s), via\n", + "# fine_mapping_upset.R (pecotmr does no plotting). trait_to_select is retained\n", + "# for CLI compatibility; the single-trait \"CS shared with other phenotypes\"\n", + "# sub-view is a deferred wrapper option.\n", + "parameter: rds_path = paths\n", + "parameter: trait_to_select = 1\n", + "input: rds_path\n", + "output: f'{cwd}/{name}.UpSetR_cs.pdf'\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container, entrypoint = entrypoint\n", + " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_upset.R \\\n", + " --input ${\" \".join([str(x) for x in _input])} \\\n", + " --output ${_output}\n" ] }, { @@ -763,55 +501,21 @@ "outputs": [], "source": [ "[fsusie_extract_effect]\n", + "# Fitted effect curve + credible band per fSuSiE credible set, via\n", + "# fsusieCredibleBand (fine_mapping_export.R `credible_band` view). pecotmr does\n", + "# the wavelet credible band; it needs an UNtrimmed fSuSiE fit (fine_mapping\n", + "# trim=FALSE). The effect-curve PDF is a deferred plot wrapper (pecotmr does no\n", + "# plotting); annot_tibble is kept for CLI compatibility.\n", "parameter: rds_path = paths\n", "parameter: annot_tibble = path(\"~/Annotatr_builtin_annotation_tibble.tsv\")\n", "input: rds_path, group_by = 1\n", - "output: f'{cwd}/{_input:bn}.estimated_effect.tsv',f'{cwd}/{_input:bn}.estimated_effect.pdf'\n", + "output: f'{cwd}/{_input:bn}.estimated_effect.tsv'\n", "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", - "R: expand = '${ }', stdout = f\"{_output[0]}.stdout\", stderr = f\"{_output[0]}.stderr\", container = container\n", - " library(\"stringr\")\n", - " library(\"dplyr\")\n", - " library(\"readr\") \n", - " library(\"ggplot2\")\n", - " library(\"purrr\")\n", - " library(\"tidyr\")\n", - " color = c(\"black\", \"dodgerblue2\", \"green4\", \"#6A3D9A\", \n", - " \"#FF7F00\", \"gold1\", \"skyblue2\", \"#FB9A99\", \"palegreen2\",\n", - " \"#CAB2D6\", \"#FDBF6F\", \"gray70\", \"khaki2\", \"maroon\", \"orchid1\",\n", - " \"deeppink1\", \"blue1\", \"steelblue4\", \"darkturquoise\", \"green1\", \n", - " \"yellow4\", \"yellow3\",\"darkorange4\",\"brown\",\"navyblue\",\"#FF0000\",\n", - " \"darkgreen\",\"#FFFF00\",\"purple\",\"#00FF00\",\"pink\",\"#0000FF\",\n", - " \"orange\",\"#FF00FF\",\"cyan\",\"#00FFFF\",\"#FFFFFF\")\n", - " \n", - " effect_extract = function(fsusie){\n", - " plot_df = fsusie$fitted_func%>%as_tibble(.name_repair = \"universal\")%>%mutate(pos = fsusie$outing_grid)%>%`colnames<-`(c(paste0(\"Effect_\",1:length(fsusie$cs)),\"pos\"))%>%mutate(`#chr` = str_split(names(fsusie$csd_X)[[1]],\":\")[[1]][[1]] )%>%select(`#chr`, pos, everything())\n", - " plot= plot_df%>%pivot_longer(cols = 3:ncol(plot_df),names_to = \"effect\", values_to = \"values\" ) %>%ggplot(aes(x = pos, y = values,color = effect),linewidth = 7)+\n", - " geom_line()+ylab(\"Estimated Effect\") + xlab(\"POS\")+facet_grid(effect~. )+\n", - " scale_color_manual(\"Credible set\",values = color[2:length(color)])+geom_line(aes(y = 0), color = \"black\")\n", - " theme(strip.text.y.right = element_text(angle = 0))+\n", - " xlab(\"\") + \n", - " ylab(\"Estimated Effect\")+ \n", - " theme(text = element_text(size = 50))+\n", - " ggtitle(paste0( \"Estimated effect for ${f'{_input:br}'.split('.')[-4]}\"))\n", - " return(list(plot_df,plot))\n", - " }\n", - " susie_obj = readRDS(\"${_input}\")\n", - " output = effect_extract(susie_obj)\n", - " effect_tbl = output[[1]]\n", - " annot = read_delim(\"${annot_tibble}\")\n", - " annot = annot%>%filter(seqnames == (effect_tbl$`#chr`)[[1]], start > min(effect_tbl$pos), end < max(effect_tbl$pos))\n", - " plot_range = c(min(effect_tbl$pos), max(effect_tbl$pos))\n", - " annot_plot = annot%>%filter(!type%in%c(\"hg38_genes_introns\",\"hg38_genes_1to5kb\"))%>%\n", - " ggplot(aes())+\n", - " geom_segment( aes(x = start,xend = end, y = \"Regulartory Element\", yend = \"Regulartory Element\", color = type ), linewidth =10)+\n", - " ylab(\"\")+xlab(\"\")+xlim(plot_range)+theme(axis.text.x=element_blank(),text = element_text(size = 20))+scale_color_brewer(palette=\"Dark2\")\n", - " gene_plot = annot%>%filter(type%in%c(\"hg38_genes_1to5kb\"))%>%group_by(symbol)%>%\n", - " summarise(start = min(start), end = max(end))%>%na.omit%>%\n", - " ggplot(aes())+geom_segment( aes(x = start,xend = end, y = \"Gene\", yend = \"Gene\", color = symbol ), linewidth =10)+\n", - " geom_label(aes(x = (start+end)/2,y = \"Gene\", label = symbol ),size = 5)+ylab(\"\")+xlab(\"POS\")+\n", - " theme(legend.position=\"none\")+theme(text = element_text(size = 20))+xlim(plot_range)\n", - " cowplot::plot_grid(plotlist = list(output[[2]]),ncol = 1, align = \"v\",axis = \"tlbr\",rel_heights = c(8))%>%ggsave(filename = \"${_output[1]}\",device = \"pdf\",dpi = \"retina\",width = 30, height = 30)\n", - " effect_tbl%>%write_delim(\"${_output[0]}\",\"\\t\")\n" + "bash: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container, entrypoint = entrypoint\n", + " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_export.R \\\n", + " --input ${_input} \\\n", + " --view credible_band \\\n", + " --output ${_output}\n" ] }, { @@ -824,100 +528,19 @@ "outputs": [], "source": [ "[fsusie_affected_region]\n", + "# GRanges of intervals where the fSuSiE credible band excludes 0 (with a\n", + "# direction mcol), via fsusieAffectedRegions (fine_mapping_export.R\n", + "# `affected_regions` view). Needs an UNtrimmed fSuSiE fit (fine_mapping\n", + "# trim=FALSE). The region PDF is a deferred plot wrapper.\n", "parameter: rds_path = paths\n", "input: rds_path, group_by = 1\n", - "output: f'{cwd}/{_input:bn}.affected_region.tsv',f'{cwd}/{_input:bn}.affected_region.pdf'\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output[0]:bn}'\n", - "R: expand = '${ }', stdout = f\"{_output[0]}.stdout\", stderr = f\"{_output[0]}.stderr\", container = container\n", - " library(\"stringr\")\n", - " library(\"dplyr\")\n", - " library(\"readr\") \n", - " library(\"ggplot2\")\n", - " library(\"purrr\")\n", - " library(\"tidyr\")\n", - " library(susiF.alpha)\n", - " library(ashr)\n", - " library(wavethresh)\n", - " color = c(\"black\", \"dodgerblue2\", \"green4\", \"#6A3D9A\", \n", - " \"#FF7F00\", \"gold1\", \"skyblue2\", \"#FB9A99\", \"palegreen2\",\n", - " \"#CAB2D6\", \"#FDBF6F\", \"gray70\", \"khaki2\", \"maroon\", \"orchid1\",\n", - " \"deeppink1\", \"blue1\", \"steelblue4\", \"darkturquoise\", \"green1\", \n", - " \"yellow4\", \"yellow3\",\"darkorange4\",\"brown\",\"navyblue\",\"#FF0000\",\n", - " \"darkgreen\",\"#FFFF00\",\"purple\",\"#00FF00\",\"pink\",\"#0000FF\",\n", - " \"orange\",\"#FF00FF\",\"cyan\",\"#00FFFF\",\"#FFFFFF\")\n", - " ## Define Function\n", - " update_cal_credible_band2 <- function(susiF.obj )\n", - " {\n", - " \n", - " \n", - " \n", - " if(sum( is.na(unlist(susiF.obj$alpha))))\n", - " {\n", - " stop(\"Error: some alpha value not updated, please update alpha value first\")\n", - " }\n", - " temp <- wavethresh::wd(rep(0, susiF.obj$n_wac))\n", - " \n", - " \n", - " for ( l in 1:susiF.obj$L)\n", - " {\n", - " Smat <- susiF.obj$fitted_wc2[[l]]\n", - " W1 <- ((wavethresh::GenW(n= ncol(Smat ) , filter.number = 10, family = \"DaubLeAsymm\")))\n", - " tt <- diag( W1%*%diag(c(susiF.obj$alpha[[l]]%*%Smat ))%*% t(W1 ))\n", - " \n", - " up <- susiF.obj$fitted_func[[l]]+ 3*sqrt(tt)\n", - " low <- susiF.obj$fitted_func[[l]]- 3*sqrt(tt)\n", - " susiF.obj$cred_band[[l]] <- rbind(up, low)\n", - " }\n", - " \n", - " \n", - " \n", - " return(susiF.obj)\n", - " }\n", - " \n", - " affected_reg <- function( susiF.obj){\n", - " outing_grid <- susiF.obj$outing_grid\n", - " \n", - " reg <- list()\n", - " h <- 1\n", - " for ( l in 1:length(susiF.obj$cs)){\n", - " \n", - " pos_up <- which(susiF.obj$cred_band[[l]][1,]<0)\n", - " pos_low <- which(susiF.obj$cred_band[[l]][2,]>0)\n", - " \n", - " \n", - " reg_up <- split( pos_up,cumsum(c(1,diff( pos_up)!=1)))\n", - " \n", - " reg_low <- split( pos_low,cumsum(c(1,diff( pos_low)!=1)))\n", - " for( k in 1:length(reg_up)){\n", - " reg[[h]] <- c(l, outing_grid[reg_up[[k]][1]], outing_grid[reg_up[[k]][length(reg_up[[k]])]])\n", - " \n", - " h <- h+1\n", - " }\n", - " for( k in 1:length(reg_low )){\n", - " reg[[h]] <- c(l, outing_grid[reg_low [[k]][1]], outing_grid[reg_low [[k]][length(reg_low [[k]])]])\n", - " \n", - " h <- h+1\n", - " }\n", - " \n", - " \n", - " }\n", - " reg <- do.call(rbind, reg)\n", - " colnames(reg) <- c(\"CS\", \"Start\",\"End\")\n", - " return(reg)\n", - " }\n", - " \n", - " \n", - " susiF_obj = readRDS(\"${_input}\")\n", - " susiF_obj = update_cal_credible_band2(susiF_obj)\n", - " affected_tbl = affected_reg(susiF_obj)\n", - " affected_tbl = affected_tbl%>%as_tibble%>%mutate(analysis = susiF_obj$name,\n", - " chr = (names(susiF_obj$csd_X)[[1]]%>%stringr::str_split(\":\"))[[1]][[1]],\n", - " molecular_trait_id = \"${f'{_input:br}'.split('.')[-4]}\", \n", - " purity = purrr::map_dbl(CS,~susiF_obj$purity[[.x]] ) )\n", - " \n", - " affected_tbl%>%as_tibble%>%write_delim(\"${_output[0]}\",\"\\t\")\n", - " plt = plot_susiF(susiF_obj, cred.band = T)\n", - " plt%>%ggsave(filename = \"${_output[1]}\",device = \"pdf\",dpi = \"retina\",width = 30, height = 30)" + "output: f'{cwd}/{_input:bn}.affected_region.tsv'\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container, entrypoint = entrypoint\n", + " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_export.R \\\n", + " --input ${_input} \\\n", + " --view affected_regions \\\n", + " --output ${_output}\n" ] }, { @@ -1043,99 +666,23 @@ "outputs": [], "source": [ "[mv_susie_2]\n", - "input: group_with = \"genoFile\"\n", - "output: f\"{_input:n}.vcf.bgz\"\n", - "task: trunk_workers = 1, trunk_size = 1, walltime = '2h', mem = '55G', cores = 1, tags = f'{step_name}_{_output[0]:bn}'\n", - "R: expand = '${ }', stdout = f\"{_output:nn}.stdout\", stderr = f\"{_output:nn}.stderr\", container = container\n", - " ## Define create_vcf function\n", - " create_vcf = function (chrom, pos, nea, ea, snp = NULL, ea_af = NULL, effect = NULL, \n", - " se = NULL, pval = NULL, name = NULL,cs = NULL, pip = NULL) \n", - " {\n", - " stopifnot(length(chrom) == length(pos))\n", - " if (is.null(snp)) {\n", - " snp <- paste0(chrom, \":\", pos)\n", - " }\n", - " snp <- paste0(chrom, \":\", pos)\n", - " nsnp <- length(chrom)\n", - " gen <- list()\n", - " ## Setupt data content for each sample column\n", - " if (!is.null(ea_af)) \n", - " gen[[\"AF\"]] <- matrix(ea_af, nsnp)\n", - " if (!is.null(effect)) \n", - " gen[[\"ES\"]] <- matrix(effect, nsnp)\n", - " if (!is.null(se)) \n", - " gen[[\"SE\"]] <- matrix(se, nsnp)\n", - " if (!is.null(pval)) \n", - " gen[[\"LP\"]] <- matrix(-log10(pval), nsnp)\n", - " if (!is.null(cs)) \n", - " gen[[\"CS\"]] <- matrix(cs, nsnp)\n", - " if (!is.null(pip)) \n", - " gen[[\"PIP\"]] <- matrix(pip, nsnp)\n", - " gen <- S4Vectors::SimpleList(gen)\n", - " \n", - " ## Setup snps info for the fix columns\n", - " gr <- GenomicRanges::GRanges(chrom, IRanges::IRanges(start = pos, \n", - " end = pos + pmax(nchar(nea), nchar(ea)) - 1, names = snp))\n", - " coldata <- S4Vectors::DataFrame(Studies = name, row.names = name)\n", - " ## Setup header informations\n", - " hdr <- VariantAnnotation::VCFHeader(header = IRanges::DataFrameList(fileformat = S4Vectors::DataFrame(Value = \"VCFv4.2\", \n", - " row.names = \"fileformat\")), sample = name)\n", - " VariantAnnotation::geno(hdr) <- S4Vectors::DataFrame(Number = c(\"A\", \n", - " \"A\", \"A\", \"A\", \"A\", \"A\"), Type = c(\"Float\", \"Float\", \n", - " \"Float\", \"Float\", \"Float\", \"Float\"), Description = c(\"Effect size estimate relative to the alternative allele\", \n", - " \"Standard error of effect size estimate\", \"-log10 p-value for effect estimate\", \n", - " \"Alternate allele frequency in the association study\",\n", - " \"The CS this variate are captured, 0 indicates not in any cs\", \"The posterior inclusion probability to a CS\"), \n", - " row.names = c(\"ES\", \"SE\", \"LP\", \"AF\", \"CS\", \"PIP\"))\n", - " ## Save only the meta information in the sample columns \n", - " VariantAnnotation::geno(hdr) <- subset(VariantAnnotation::geno(hdr), \n", - " rownames(VariantAnnotation::geno(hdr)) %in% names(gen))\n", - " ## Save VCF \n", - " vcf <- VariantAnnotation::VCF(rowRanges = gr, colData = coldata, \n", - " exptData = list(header = hdr), geno = gen)\n", - " VariantAnnotation::alt(vcf) <- Biostrings::DNAStringSetList(as.list(ea))\n", - " VariantAnnotation::ref(vcf) <- Biostrings::DNAStringSet(nea)\n", - " ## Add fixed values\n", - " VariantAnnotation::fixed(vcf)$FILTER <- \"PASS\"\n", - " return(sort(vcf))\n", - " }\n", - " library(\"susieR\")\n", - " library(\"dplyr\")\n", - " library(\"tibble\")\n", - " library(\"purrr\")\n", - " library(\"readr\")\n", - " library(\"tidyr\")\n", - " \n", - " # Get list of cs snps\n", - " res = readRDS(${_input:r})\n", - " output_snps = tibble( snps = res$variable_name[which(res$pip >= 0)], snps_index = which((res$pip >= 0)) )\n", - " output_snps = output_snps%>%mutate( cs = map(snps_index,~which(res$sets$cs %in% .x))%>%as.numeric%>%replace_na(0),\n", - " pip = map_dbl(snps_index,~(res$pip[.x])),\n", - " chr = map_chr(snps,~read.table(text = .x,sep = \":\",as.is = T)$V1),\n", - " pos_alt_ref = map_chr(snps,~read.table(text = .x,sep = \":\",as.is = TRUE)$V2),\n", - " pos = map_dbl(pos_alt_ref,~read.table(text = .x,sep = \"_\",as.is = TRUE)$V1),\n", - " alt = map_chr(pos_alt_ref,~read.table(text = .x,sep = \"_\",as.is = TRUE, colClass = \"character\")$V2),\n", - " ref = map_chr(pos_alt_ref,~read.table(text = .x,sep = \"_\",as.is = TRUE, colClass = \"character\")$V3))\n", - " \n", - " effect_mtr = res$coef[output_snps$snps_index+1]%>%as.matrix\n", - " colnames(effect_mtr) = \"${name}\"\n", - " rownames(effect_mtr) = output_snps$snps\n", - " cs_mtr = effect_mtr\n", - " for(i in 1:nrow(cs_mtr)) cs_mtr[i,] = output_snps$cs[[i]] \n", - " pip_mtr = effect_mtr\n", - " for(i in 1:nrow(pip_mtr)) pip_mtr[i,] = output_snps$pip[[i]] \n", - " \n", - " output_vcf = create_vcf(\n", - " chrom = output_snps$chr,\n", - " pos = output_snps$pos,\n", - " ea = output_snps$alt,\n", - " nea = output_snps$ref,\n", - " effect = effect_mtr ,\n", - " pip = pip_mtr,\n", - " cs = cs_mtr,\n", - " name = colnames(effect_mtr)\n", - " )\n", - " VariantAnnotation::writeVcf(output_vcf,${_output:nr},index = TRUE)" + "# Write per-context fine-mapping VCFs (ES / SE / LP / AF + PIP / CS / within_cs_pip\n", + "# in the sample column) from a FineMappingResult via fine_mapping_vcf.R ->\n", + "# pecotmr::writeSumstatsVcf, replacing the inline create_vcf. writeSumstatsVcf\n", + "# splits a multi-context collection into one .vcf.bgz per context; the runtime\n", + "# set is tracked with output: dynamic() (so {cwd} must be created up front, since\n", + "# a dynamic output -- unlike a concrete target -- does not pre-create its dir).\n", + "parameter: rds_path = paths\n", + "import os\n", + "os.makedirs(str(cwd), exist_ok=True)\n", + "input: rds_path, group_by = 1\n", + "output: dynamic(f\"{cwd}/{_input:bn}.*.vcf.bgz\")\n", + "task: trunk_workers = 1, trunk_size = 1, walltime = '2h', mem = mem, cores = 1, tags = f'{step_name}_{_input:bn}'\n", + "bash: expand = '${ }', stdout = f\"{cwd}/{_input:bn}.vcf.stdout\", stderr = f\"{cwd}/{_input:bn}.vcf.stderr\", container = container, entrypoint = entrypoint\n", + " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_vcf.R \\\n", + " --input ${_input} \\\n", + " --output ${cwd}/${_input:bn}.vcf.bgz \\\n", + " --split-by-context\n" ] }, { @@ -1151,7 +698,7 @@ "[cis_results_export_1, gwas_results_export_1, export_top_loci_1]\n", "# per chunk we process at most 200 datasets\n", "parameter: per_chunk = 200\n", - "# Region list should have last column being region name. \n", + "# Region list should have last column being region name.\n", "parameter:region_file=path()\n", "# the path stored original output files\n", "parameter:file_path=''\n", @@ -1164,22 +711,23 @@ "parameter: condition_meta = path()\n", "# if the pip all variants in a cs < this threshold, then remove this cs\n", "parameter: pip_thres = 0.05\n", - "# only keep top cs_size variants in one cs \n", + "# only keep top cs_size variants in one cs\n", "parameter: cs_size = 3\n", - "# provide exported meta to filter the exported genes \n", + "# provide exported meta to filter the exported genes\n", "parameter: exported_file = path()\n", - "# Optional: if a region list is provide the analysis will be focused on provided region. \n", + "# Optional: if a region list is provide the analysis will be focused on provided region.\n", "# The LAST column of this list will contain the ID of regions to focus on\n", - "# Otherwise, all regions with both genotype and phenotype files will be analyzed\n", "parameter: region_list = path()\n", - "# Optional: if a region name is provided \n", + "# Optional: if a region name is provided\n", "# the analysis would be focused on the union of provides region list and region names\n", "parameter: region_name = []\n", - "# the (aligned) geno bim file to check allele flipping\n", + "# the (aligned) geno bim file to check allele flipping. Retained for CLI\n", + "# compatibility; allele alignment is now done upstream by fine_mapping.R\n", + "# (matchVariants), so it is unused here.\n", "parameter: geno_ref = path()\n", "# context meta file to map renamed context backs\n", "parameter: context_meta = path()\n", - "# default cretria in susie purity filtering, recommended to use 0.8 here \n", + "# CS purity (min.abs.corr) cutoff(s); the first value is used for conditions_top_loci.\n", "parameter: min_corr = []\n", "# set this parameter as `True` when exporting gwas data.\n", "parameter: gwas = False\n", @@ -1190,760 +738,56 @@ "# set this parameter as `True` when exporting mnm data.\n", "parameter: mnm = False\n", "\n", - "import pandas as pd\n", + "# Orchestration only (no pandas / no helper defs): resolve, per region, the\n", + "# existing per-study/context FineMappingResult input file(s). The heavy legacy\n", + "# work (allele alignment, top-loci processing, combined-db assembly) now lives\n", + "# in fine_mapping.R + the fine_mapping_cis_db_export.R wrapper below.\n", "import os\n", "\n", - "region = pd.read_csv(region_file, sep='\\t', names=['chr', 'start', 'end', 'id'])\n", - "\n", - "region_ids = []\n", - "# If region_list is provided, read the file and extract IDs\n", - "if not region_list.is_dir():\n", - " if region_list.is_file():\n", - " region_list_df = pd.read_csv(region_list, sep='\\t', header=None, comment = \"#\")\n", - " region_ids = region_list_df.iloc[:, -1].unique() # Extracting the last column for IDs\n", - " else:\n", - " raise ValueError(\"The region_list path provided is not a file.\")\n", - " \n", - "if len(region_name) > 0:\n", - " region_ids = list(set(region_ids).union(set(region_name)))\n", - " \n", - "if len(region_ids) > 0:\n", - " region = region[region['id'].isin(region_ids)]\n", - "\n", - "def filter_existing_paths(row):\n", - " existing_paths = [path for path in row if os.path.exists(path)]\n", - " return existing_paths\n", - " \n", - "# Function to create list of formatted strings for each row\n", - "def create_formatted_list(row):\n", - " rid_plain = str(row['id']) # name with chr\n", - " rid_chr = f\"{row['chr']}_{row['id']}\" # name without chr\n", - " \n", - " if len(prefix) > 0:\n", - " candidates_plain = [f\"{file_path}/{p}.{rid_plain}.{suffix}\" for p in prefix]\n", - " candidates_chr = [f\"{file_path}/{p}.{rid_chr}.{suffix}\" for p in prefix]\n", - " else:\n", - " candidates_plain = [f\"{file_path}/{rid_plain}.{suffix}\"] # GWAS data do not have prefix\n", - " candidates_chr = [f\"{file_path}/{rid_chr}.{suffix}\"]\n", - " \n", - " # prioritize plain\n", - " existing_plain = filter_existing_paths(candidates_plain)\n", - " if existing_plain:\n", - " return existing_plain\n", - " \n", - " existing_chr = filter_existing_paths(candidates_chr)\n", - " return existing_chr\n", - "\n", - "# Apply the function to each row\n", - "region['original_data'] = region.apply(create_formatted_list, axis=1)\n", - "\n", - "def group_by_region(lst, partition):\n", - " # from itertools import accumulate\n", - " # partition = [len(x) for x in partition]\n", - " # Compute the cumulative sums once\n", - " # cumsum_vector = list(accumulate(partition))\n", - " # Use slicing based on the cumulative sums\n", - " # return [lst[(cumsum_vector[i-1] if i > 0 else 0):cumsum_vector[i]] for i in range(len(partition))]\n", - " return partition\n", - "\n", - "\n", - "def is_file_exported(paths, results_set):\n", - " for path in paths:\n", - " basename = os.path.basename(path)\n", - " if basename not in results_set:\n", - " return False\n", - " return True\n", - "\n", - "region['original_data'] = region['original_data'].apply(filter_existing_paths)\n", - "region = region[region['original_data'].map(bool)]\n", - "\n", - "# if provided exported meta, check if the original data are all exported already, isfo skip them \n", - "if not exported_file.is_dir():\n", - " if exported_file.is_file():\n", - " results = pd.read_csv(exported_file, sep='\\t')\n", - " results_set = set(results['original_data'])\n", - " results_set = {item.strip() for sub in results_set for item in sub.split(',')}\n", - " mask = region['original_data'].apply(lambda paths: not is_file_exported(paths, results_set))\n", - " region = region[mask]\n", - " else:\n", - " raise ValueError(\"The exported_file path provided is not a file.\")\n", - "\n", - "# added because there is frequently changed ID from upstream analysis!!! \n", - "# If after filtering no region remains, update 'id' by concatenating 'chr' and original 'id' with '_'\n", - "if region.empty:\n", - " print(\"No regions remain after filtering. Reattempting using concatenated id (chr_id).\")\n", - " # Update the 'id' column using the concatenation of the first column (chr) and the original 'id'\n", - " region = pd.read_csv(region_file, sep='\\t', names=['chr', 'start', 'end', 'id'])\n", - " region['id_chr'] = region['chr'].astype(str) + \"_\" + region['id'].astype(str)\n", - " \n", - " if len(region_ids) > 0:\n", - " region = region[region['id'].isin(region_ids) | region['id_chr'].isin(region_ids)]\n", - " \n", - " if region.empty:\n", - " print(\"Still no regions matched after using id_chr.\")\n", - " else:\n", - " region['original_data'] = region.apply(create_formatted_list, axis=1)\n", - " region = region[region['original_data'].map(bool)]\n", - " \n", - " # Reapply exported_file filtering if applicable\n", - " if not exported_file.is_dir():\n", - " if exported_file.is_file():\n", - " results = pd.read_csv(exported_file, sep='\\t')\n", - " results_set = set(results['original_data'])\n", - " results_set = {item.strip() for sub in results_set for item in sub.split(',')}\n", - " mask = region['original_data'].apply(lambda paths: not is_file_exported(paths, results_set))\n", - " region = region[mask]\n", - " else:\n", - " raise ValueError(\"The exported_file path provided is not a file.\")\n", - "regional_data = {\n", - " 'meta': [(row['chr'], row['start'], row['end'], row['id']) for _, row in region.iterrows()],\n", - " 'data': [(row['original_data']) for _, row in region.iterrows()]\n", - "}\n", - "\n", + "_region_rows = [tuple((_l.rstrip('\\n').split('\\t') + ['', '', '', ''])[:4])\n", + " for _l in open(region_file)\n", + " if _l.strip() and not _l.startswith('#')]\n", + "\n", + "_focus = set(region_name)\n", + "if region_list.is_file():\n", + " _focus |= {_l.rstrip('\\n').split('\\t')[-1] for _l in open(region_list)\n", + " if _l.strip() and not _l.startswith('#')}\n", + "if len(_focus) > 0:\n", + " _region_rows = [r for r in _region_rows if r[3] in _focus or f\"{r[0]}_{r[3]}\" in _focus]\n", + "\n", + "# candidate names: prefix.id.suffix (plain id first, then chr_id), pick existing.\n", + "_pfxs = list(prefix) if len(prefix) > 0 else ['']\n", + "_meta = []\n", + "_data = []\n", + "for _chr, _start, _end, _id in _region_rows:\n", + " _plain = [f\"{file_path}/{(p + '.') if p else ''}{_id}.{suffix}\" for p in _pfxs]\n", + " _plain = [c for c in _plain if os.path.exists(c)]\n", + " _chrid = [f\"{file_path}/{(p + '.') if p else ''}{_chr}_{_id}.{suffix}\" for p in _pfxs]\n", + " _chrid = [c for c in _chrid if os.path.exists(c)]\n", + " _files = _plain if _plain else _chrid\n", + " if _files:\n", + " _meta.append((_chr, _start, _end, _id))\n", + " _data.append(_files)\n", + "\n", + "regional_data = {'meta': _meta, 'data': _data}\n", "meta_info = regional_data['meta']\n", - "stop_if(len(regional_data['data']) == 0, f' All files have been exported already')\n", + "stop_if(len(regional_data['data']) == 0, 'No input FineMappingResult files found for any region.')\n", + "# db suffix mirrors cis_results_export_2's block_results_db / cis_results_db split\n", + "_db_kind = 'block_results_db' if gwas else 'cis_results_db'\n", + "_purity_arg = f\"--min-purity {min_corr[0]}\" if len(min_corr) > 0 else \"\"\n", "\n", - "input: regional_data[\"data\"], group_by = lambda x: group_by_region(x, regional_data[\"data\"]), group_with = \"meta_info\"\n", + "input: regional_data[\"data\"], group_by = lambda x: regional_data[\"data\"], group_with = \"meta_info\"\n", "output: f\"{cwd}/{name}_cache/{name}_{_meta_info[3]}.tsv\"\n", "task: trunk_workers = job_size, walltime = walltime, trunk_size = job_size, mem = mem, cores = numThreads, tags = f'{_output:bn}'\n", - "R: expand = \"${ }\",stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", - " library(tidyverse)\n", - " library(data.table)\n", - " library(susieR)\n", - " library(pecotmr)\n", - "\n", - " # check top_loci existing or not\n", - " has_rows <- function(df) {\n", - " !is.null(df) && nrow(df) > 0\n", - " }\n", - "\n", - " # function to allele flipping checking by mapping them to aligned genotype bim file\n", - " align_to_genoref <- function(var_list, geno_ref, region ){\n", - " geno_ref <- pecotmr:::tabix_region(file= geno_ref,\n", - " region = region)\n", - " colnames(geno_ref) <- c('chr', 'pos', 'alt', 'ref')\n", - " geno_ref <- geno_ref %>% mutate(chr = gsub('chr','',chr))\n", - " var_list_df <- data.frame(chr = str_split(var_list,\":|_\",simplify = T)[,1] %>% gsub('chr','',.),\n", - " pos = str_split(var_list,\":|_\",simplify = T)[,2],\n", - " ref = str_split(var_list,\":|_\",simplify = T)[,3],\n", - " alt = str_split(var_list,\":|_\",simplify = T)[,4])\n", - " # merge_genotype_data from below cell\n", - " aligned_var_df <- merge_genotype_data(geno_ref, var_list_df, all=FALSE)\n", - " aligned_var <- aligned_var_df %>%\n", - " mutate(id = {\n", - " if (grepl(\":\", var_list[1])) {\n", - " if (grepl(\"_\", var_list[1])) {\n", - " paste(chr, paste(pos, ref, alt, sep = \"_\"),sep = ':')\n", - " } else {\n", - " paste(chr, pos, ref, alt, sep = \":\")\n", - " }\n", - " } else {\n", - " paste(chr, pos, ref, alt, sep = \"_\")\n", - " }\n", - " }) %>%\n", - " pull(id)\n", - " if (grepl(\"chr\", var_list[1])) aligned_var <- paste0(\"chr\",aligned_var)\n", - " return(aligned_var)\n", - " }\n", - " \n", - " # function to map variant list to geno ref\n", - " merge_genotype_data <- function(df1, df2, all = TRUE) {\n", - " setDT(df1)\n", - " setDT(df2)\n", - " df1[, key := paste(chr, pos, pmin(alt, ref), pmax(alt, ref))]\n", - " df2[, key := paste(chr, pos, pmin(alt, ref), pmax(alt, ref))]\n", - " df2[df1, on = \"key\", flip := i.alt == ref & i.ref == alt, by = .EACHI]\n", - " df2[flip == TRUE, c(\"alt\", \"ref\") := .(ref, alt)]\n", - " if (all) {\n", - " df_combined <- unique(rbindlist(list(df1[, .(chr, pos, alt, ref)], df2[, .(chr, pos, alt, ref)])), by = c(\"chr\", \"pos\", \"alt\", \"ref\"))\n", - " } else {\n", - " df_combined <- df2[, .(chr, pos, alt, ref)]\n", - " }\n", - " return(df_combined)\n", - " }\n", - "\n", - " # Function to filter credible sets with all variants PIP < 0.05 and update rows based on _min_corr suffix condition\n", - " update_and_filter_cs_ids <- function(dat_con, dat_susie, df, purity_thresholds) {\n", - " # Identify cs_coverage columns\n", - " cs_columns <- grep(\"^cs_coverage\", names(df), value = TRUE)\n", - " \n", - " # Flag rows with any cs_coverage > 0\n", - " df$cs_all_non_zero_orig <- rowSums(df[cs_columns] == 0) != length(cs_columns)\n", - " \n", - " # Iterate over cs_coverage columns and their unique CS IDs\n", - " for (cs_column in cs_columns) {\n", - " unique_cs_ids <- unique(df[[cs_column]])\n", - " # Update top loci based on minimum correlation for each coverage column\n", - " for(purity_threshold in purity_thresholds){\n", - " df <- update_top_loci_cs_annotation(dat_con, dat_susie, top_loci_df = df, coverage_value = cs_column, threshold = purity_threshold)\n", - " }\n", - " \n", - " for (cs_id in unique_cs_ids[unique_cs_ids > 0]) {\n", - " # Flag CS IDs where all PIPs < pip_thres (default 0.05)\n", - " pip_check <- df[df[[cs_column]] == cs_id, \"pip\"] < 0.05\n", - " # label the whole cluster if all pip < pip_thres (default 0.05)\n", - " if (all(pip_check, na.rm = TRUE)) {\n", - " df[[cs_column]] <- ifelse(df[[cs_column]] == cs_id, 0, df[[cs_column]])\n", - " }\n", - " }\n", - " }\n", - " # Identify min corr cs_coverage columns\n", - " mincor_columns <- grep(\"_min_corr\", names(df), value = TRUE) # Identify _mincor columns\n", - " \n", - " # Filter out rows where all cs_coverage columns are 0, all _mincor columns are 0,\n", - " # and cs_all_non_zero_orig is TRUE\n", - " df <- df %>%\n", - " filter(!(cs_all_non_zero_orig &\n", - " rowSums(df[cs_columns] == 0) == length(cs_columns) &\n", - " rowSums(df[mincor_columns] == 0) == length(mincor_columns))) %>%\n", - " select(-cs_all_non_zero_orig) # Remove the temporary flag column\n", - " df <- df %>%\n", - " select(-starts_with(\"cs_coverage\"), all_of(cs_columns), all_of(mincor_columns))\n", - " return(df)\n", - " }\n", - " \n", - " \n", - " # update top loci table\n", - " update_top_loci_cs_annotation <- function(dat_con, dat_susie, top_loci_df, coverage_value, threshold ) {\n", - " # update susie obj based CS\n", - " if(coverage_value == 'cs_coverage_0.95') dat_susie_tmp <- dat_susie\n", - " else dat_susie_tmp <- dat_susie$sets_secondary[[gsub('cs_','',coverage_value)]]\n", - " #get purity res \n", - " purity_res <- dat_susie_tmp$sets$purity \n", - " \n", - " not_pass_min_cs <- rownames(purity_res)[purity_res$min.abs.corr < threshold] %>%\n", - " gsub('L', '', .)\n", - " top_loci_df[[paste0( coverage_value, \"_min_corr_\", threshold)]] <- top_loci_df[[coverage_value]]\n", - " if (length(not_pass_min_cs) > 0) {\n", - " top_loci_df[[paste0( coverage_value, \"_min_corr_\", threshold)]][top_loci_df[[coverage_value]] %in% not_pass_min_cs] <- 0\n", - " }\n", - " return(top_loci_df)\n", - " }\n", - " \n", - " # function to decide run update_and_filter_cs_ids or not\n", - " process_top_loci <- function(dat_con, dat_susie,purity_thresholds) {\n", - " data_frame <- dat_con$top_loci\n", - " if (has_rows(data_frame)) {\n", - " return(update_and_filter_cs_ids(dat_con, dat_susie, data_frame, purity_thresholds))\n", - " } else {\n", - " return(data_frame)\n", - " }\n", - " }\n", - "\n", - " # function to get pip with their variant name\n", - " get_pip_withname <- function(susie_obj){\n", - " pip = susie_obj$susie_result_trimmed$pip\n", - " if(!(is.null(pip))) names(pip) = susie_obj$variant_names\n", - " return(pip)\n", - " }\n", - " \n", - " # add column in top loci to indicate if the variant is identified in susie_on_top_pc top loci table or not\n", - " annotate_susie <- function(obj, top_loci){\n", - " tryCatch({\n", - " df <- data.frame()\n", - " \n", - " results <- lapply(obj[['susie_on_top_pc']], function(x) {\n", - " x[['top_loci']]\n", - " })\n", - " results <- results[!sapply(results, is.null)]\n", - " \n", - " df <- bind_rows(results)\n", - " \n", - " top_loci_others <- df %>%\n", - " filter(rowSums(select(., starts_with('cs_coverage_'))) == 0)\n", - " top_loci_cs <- df %>%\n", - " filter(rowSums(select(., starts_with('cs_coverage_'))) > 0)\n", - " \n", - " susie_vars <- rbind(top_loci_others %>% filter(pip >= 0.05), top_loci_cs) %>% pull(variant_id)\n", - " if(length(susie_vars) > 0) susie_vars <- align_to_genoref(var_list = susie_vars, geno_ref = geno_ref, region = paste0(sub(\"^(chr)?\",\"chr\",\"${_meta_info[0]}\"), \":\", \"${_meta_info[1]}\", \"-\", \"${_meta_info[2]}\"))\n", - " \n", - " susie_vars_cs <- top_loci_cs %>% pull(variant_id)\n", - " if(length(susie_vars_cs) > 0) susie_vars_cs <- align_to_genoref(var_list = susie_vars_cs, geno_ref = geno_ref, region = paste0(sub(\"^(chr)?\",\"chr\",\"${_meta_info[0]}\"), \":\", \"${_meta_info[1]}\", \"-\", \"${_meta_info[2]}\"))\n", - " \n", - " top_loci <- top_loci %>% mutate(annotated_susie = ifelse(variant_id %in% susie_vars, 1, 0),\n", - " annotated_susie_cs = ifelse(variant_id %in% susie_vars_cs, 1, 0))\n", - " \n", - " return(top_loci)\n", - " }, error = function(e) {\n", - " warning(\"Error in annotate_susie: \", e$message)\n", - " })\n", - " }\n", - " \n", - " # function to match context values and add analysis_name\n", - " match_contexts <- function(df, context_meta) {\n", - " # Split context_meta's context column into separate rows, one for each comma-separated value\n", - " context_meta_expanded <- context_meta %>% \n", - " separate_rows(context, sep = \",\") %>%\n", - " mutate(context = trimws(context)) # Remove potential leading and trailing whitespace\n", - "\n", - " # Loop through each context in df to find the most precise match in context_meta_expanded\n", - " df$super_context <- sapply(df$context, function(df_context) {\n", - " # Find all potential matches\n", - " potential_matches <- context_meta_expanded %>%\n", - " filter(str_detect(df_context, context)) %>%\n", - " arrange(desc(nchar(context))) # Sort potential matches by descending length of context\n", - "\n", - " # Select the longest match as the most precise one\n", - " if(nrow(potential_matches) > 0) {\n", - " return(potential_matches$context[1])\n", - " } else {\n", - " return(NA) # Return NA if no match is found\n", - " }\n", - " })\n", - "\n", - " return(df)\n", - " }\n", - " # Define a function to process context data and match contexts\n", - " process_and_match_contexts <- function(context_meta_path, cons_top_loci, res_minp) {\n", - " # Read context metadata\n", - " context_meta <- fread(context_meta_path)\n", - "\n", - " # Extract super contexts\n", - " super_contexts <- cons_top_loci[[1]] %>% unlist %>% names %>% as.character\n", - " # Create a data frame of context and minimum p-values\n", - " context_df <- data.frame(context = super_contexts,\n", - " min_p = res_minp[[1]][super_contexts] %>% unlist %>% as.numeric)\n", - " # Match contexts using the previously defined match_contexts function\n", - " context_df <- match_contexts(context_df, context_meta)\n", - " # Filter context_df by super_context\n", - " context_df_no_order <- context_df %>% filter(context == super_context)\n", - " context_df_with_order <- context_df %>% filter(context != super_context) \n", - "\n", - " return(list(context_df_no_order= context_df_no_order,context_df_with_order = context_df_with_order ))\n", - " }\n", - "\n", - " # Function to filter introns based on leafcutter2 cluster\n", - " process_lf2_cluster <- function(df){\n", - " df <- df%>%\n", - " mutate(cluster_id = str_extract(context, \"clu_\\\\d+\"), \n", - " category = str_extract(context, \"([^:]+)(?=:EN)\")) %>%\n", - " group_by(cluster_id) %>%\n", - " # filter the intron clusters with NE and IN events\n", - " mutate(cluster_status = ifelse(any(category %in% c(\"NE\", \"IN\")), \"no\", \"yes\")) %>%\n", - " filter(cluster_status == \"yes\") %>%\n", - " ungroup %>%\n", - " filter(!str_detect(context, \":PR:\")) %>% #FIXME: only keep unproductive events in leafcutter2 results. \n", - " select(-cluster_status, -cluster_id, -category)\n", - " return(df)\n", - " }\n", - "\n", - " # Function to combine the contexted with and without order \n", - " combine_order <- function(context_df_no_order, context_df_with_order){\n", - " context_df_with_order <- context_df_with_order %>%\n", - " group_by(super_context) %>%\n", - " summarise(min_p = min(min_p), .groups = 'keep') %>%\n", - " left_join(context_df_with_order, by = c(\"super_context\", \"min_p\" = \"min_p\"))\n", - "\n", - " # Combine context_df_no_order and context_df_with_order contexts\n", - " cons_top_loci_minp <- c(context_df_no_order$context, context_df_with_order$context)\n", - " return(cons_top_loci_minp)\n", - " }\n", - " \n", - " # Revised summarise_lfsr_by_marker function with distinct error cases\n", - " summarise_lfsr_by_marker <- function(multicontext_res,\n", - " pos = NULL,\n", - " markers = NULL,\n", - " conditions = NULL,\n", - " poslim = NULL,\n", - " lfsr_cutoff = 0.01,\n", - " sentinel_only = FALSE,\n", - " cs_plot = NULL,\n", - " conditional_effect = TRUE) {\n", - " tryCatch({\n", - " # Extract fitted object from multicontext_res\n", - " fit <- multicontext_res[[1]]$mvsusie_fitted\n", - " \n", - " # Set default parameters if not provided\n", - " if (is.null(markers)) markers <- fit$variable_names\n", - " if (is.null(conditions)) conditions <- fit$condition_names\n", - " if (is.null(pos)) pos <- seq(1, length(markers))\n", - " if (is.null(poslim)) poslim <- range(pos)\n", - " if (is.null(cs_plot)) cs_plot <- names(fit$sets$cs)\n", - " \n", - " # Create initial data frame for plotting\n", - " pdat <- data.frame(pip = fit$pip, pos = pos, cs = as.character(NA),\n", - " stringsAsFactors = FALSE)\n", - " css <- names(fit$sets$cs)\n", - " for (i in css) {\n", - " j <- fit$sets$cs[[i]]\n", - " pdat[j, \"cs\"] <- i\n", - " }\n", - " rows <- which(!is.na(pdat$cs))\n", - " pdat_cs <- pdat[rows, ]\n", - " \n", - " # Filter by position limits\n", - " rows1 <- which(pdat$pos >= poslim[1] & pdat$pos <= poslim[2])\n", - " rows2 <- which(pdat_cs$pos >= poslim[1] & pdat_cs$pos <= poslim[2])\n", - " pdat <- pdat[rows1, ]\n", - " pdat_cs <- pdat_cs[rows2, ]\n", - " \n", - " # Order and label credible sets\n", - " pdat_cs$cs <- factor(pdat_cs$cs)\n", - " css <- levels(pdat_cs$cs)\n", - " L <- length(css)\n", - " cs_pos <- sapply(fit$sets$cs[css], function(x) median(pos[x]))\n", - " css <- css[order(cs_pos)]\n", - " pdat_cs$cs <- factor(pdat_cs$cs, levels = css)\n", - " cs_size <- sapply(fit$sets$cs[css], length)\n", - " for (i in 1:L) {\n", - " j <- css[i]\n", - " if (cs_size[i] == 1) {\n", - " levels(pdat_cs$cs)[i] <- sprintf(\"%s (1 SNP)\", j)\n", - " } else {\n", - " levels(pdat_cs$cs)[i] <- sprintf(\"%s (%d SNPs, %0.3f purity)\",\n", - " j, cs_size[j], fit$sets$purity[j, \"min.abs.corr\"])\n", - " }\n", - " }\n", - " \n", - " # Set up traits and effects matrix\n", - " traits <- conditions\n", - " r <- length(traits)\n", - " lmax <- nrow(fit$alpha)\n", - " fit$b1_rescaled <- fit$b1_rescaled[, -1, ]\n", - " rownames(fit$b1_rescaled) <- paste0(\"L\", 1:lmax)\n", - " rownames(fit$single_effect_lfsr) <- paste0(\"L\", 1:lmax)\n", - " colnames(fit$single_effect_lfsr) <- traits\n", - " rownames(fit$alpha) <- paste0(\"L\", 1:lmax)\n", - " effects <- matrix(0, r, L)\n", - " rownames(effects) <- traits\n", - " colnames(effects) <- css\n", - " \n", - " # Initialize effect data frame\n", - " effect_dat <- data.frame(matrix(as.numeric(NA),\n", - " prod(length(conditions) * length(markers)), 8))\n", - " names(effect_dat) <- c(\"trait\", \"marker\", \"pos\", \"effect\", \"z\", \"lfsr\", \"cs\", \"sentinel\")\n", - " effect_dat$trait <- rep(conditions, length(markers))\n", - " effect_dat$marker <- rep(markers, each = length(conditions))\n", - " effect_dat$pos <- rep(pos, each = length(conditions))\n", - " effect_dat$sentinel <- 0\n", - " \n", - " # Process each credible set\n", - " for (i in 1:L) {\n", - " l <- css[i]\n", - " j <- fit$sets$cs[[l]]\n", - " b <- fit$b1_rescaled[l, j, ]\n", - " if (conditional_effect) {\n", - " b <- b / fit$alpha[l, j]\n", - " }\n", - " marker_names <- markers[j]\n", - " marker_idx <- which(effect_dat$marker %in% marker_names)\n", - " effect_dat[marker_idx, \"cs\"] <- l\n", - " effect_dat[marker_idx, \"lfsr\"] <- rep(fit$single_effect_lfsr[l, ], length(marker_names))\n", - " effect_dat[marker_idx, \"effect\"] <- as.vector(t(b))\n", - " if (!is.null(fit$z)) {\n", - " effect_dat[marker_idx, \"z\"] <- as.vector(t(fit$z[j, ]))\n", - " }\n", - " max_idx <- which.max(fit$alpha[l, j])\n", - " effect_dat[which(effect_dat$marker == marker_names[max_idx]), \"sentinel\"] <- 1\n", - " effects[, i] <- ifelse(is.null(nrow(b)), b, b[max_idx, ])\n", - " }\n", - " \n", - " # Filter and process effect data\n", - " effect_dat <- effect_dat[which(!is.na(effect_dat$cs)), ]\n", - " rows1 <- which(effect_dat$pos >= poslim[1] & effect_dat$pos <= poslim[2])\n", - " effect_dat <- effect_dat[rows1, ]\n", - " effect_dat$marker_cs <- paste0(effect_dat$marker, \"(\", effect_dat$cs, \")\")\n", - " pdat_sentinel <- effect_dat[which(effect_dat$sentinel == 1), ]\n", - " pdat_sentinel <- unique(pdat_sentinel[, c(\"marker\", \"marker_cs\", \"pos\")])\n", - " pdat_sentinel$pip <- fit$pip[match(pdat_sentinel$marker, fit$variable_names)]\n", - " \n", - " # Optionally keep only sentinel variants\n", - " if (sentinel_only) {\n", - " effect_dat <- effect_dat[which(effect_dat$sentinel == 1), ]\n", - " }\n", - " # Optionally filter by specified credible sets to plot\n", - " if (!missing(cs_plot)) {\n", - " effect_dat <- effect_dat[which(effect_dat$cs %in% cs_plot), ]\n", - " }\n", - " effect_dat$cs <- factor(effect_dat$cs, levels = css)\n", - " effect_dat$trait <- factor(effect_dat$trait, traits)\n", - " rows <- which(effect_dat$lfsr < lfsr_cutoff)\n", - " effect_dat <- effect_dat[rows, ]\n", - " \n", - " # Error Case 1: No variants left after LFSR cutoff filtering\n", - " if (nrow(effect_dat) == 0) {\n", - " message(\"Warning Case 1: No variants passed the LFSR cutoff threshold; returning NA values.\")\n", - " top_loci <- multicontext_res[[1]][['top_loci']]\n", - " top_loci$trait <- NA\n", - " top_loci$lfsr <- NA\n", - " return(top_loci)\n", - " }\n", - " \n", - " effect_dat <- effect_dat %>% \n", - " mutate(pip = fit$pip[match(marker, names(fit$pip))],\n", - " variant_id = marker)\n", - " \n", - " # Summarise results and merge with top loci\n", - " result <- effect_dat %>%\n", - " group_by(variant_id, cs) %>%\n", - " arrange(trait) %>%\n", - " summarise(trait = paste(trait, collapse = \";\"), \n", - " lfsr = paste(lfsr, collapse = \";\"),\n", - " .groups = \"drop\") %>% \n", - " mutate(cs_coverage_0.95 = gsub('L', '', cs)) %>%\n", - " select(-cs)\n", - " \n", - " top_loci <- multicontext_res[[1]][['top_loci']]\n", - " merge(top_loci, result, by = c('variant_id', 'cs_coverage_0.95'), all.x = TRUE)\n", - " }, error = function(e) {\n", - " # Error Case 2: Any unexpected error in processing\n", - " message(\"Warning Case 2: An unexpected error occurred: \", e$message)\n", - " top_loci <- tryCatch(multicontext_res[[1]][['top_loci']],\n", - " error = function(x) data.frame(variant_id = NA, cs_coverage_0.95 = NA))\n", - " top_loci$trait <- NA\n", - " top_loci$lfsr <- NA\n", - " return(top_loci)\n", - " })\n", - " }\n", - " \n", - " # function to add effect size\n", - " add_coef_column <- function(dat_study) {\n", - " # Ensure the required components exist\n", - " # Check if dat_study contains both required components\n", - " if (!(\"susie_result_trimmed\" %in% names(dat_study)) || !(\"top_loci\" %in% names(dat_study))) {\n", - " # Return a null list instead of stopping\n", - " return(data.frame())\n", - " }\n", - " \n", - " # Extract the coefficient matrix and ensure top_loci is a data.frame\n", - " coef_matrix <- dat_study[[\"susie_result_trimmed\"]][[\"coef\"]][-1,] / dat_study[[\"susie_result_trimmed\"]][['pip']]\n", - " dt <- dat_study[[\"top_loci\"]]\n", - " if (!is.data.frame(dt)) {\n", - " dt <- as.data.frame(dt)\n", - " }\n", - " \n", - " # Check that dt has the required columns\n", - " if (!all(c(\"variant_id\", \"trait\") %in% names(dt))) {\n", - " stop(\"The 'top_loci' data frame must contain 'variant_id' and 'trait' columns.\")\n", - " }\n", - " \n", - " # Add the 'coef' column by matching each variant with its corresponding traits\n", - " dt[[\"conditional_effect\"]] <- mapply(function(variant, trait_str) {\n", - " # Return NA if trait_str is missing or variant not found in coef_matrix\n", - " if (is.na(trait_str) || !(variant %in% rownames(coef_matrix))) {\n", - " return(NA_character_)\n", - " }\n", - " # Split the trait string by ';' and trim extra whitespace\n", - " traits <- trimws(unlist(strsplit(trait_str, \";\")))\n", - " # Subset coefficients for the variant and specified traits\n", - " coefs <- coef_matrix[variant, traits, drop = TRUE]\n", - " paste(coefs, collapse = \";\")\n", - " }, dt[[\"variant_id\"]], dt[[\"trait\"]], USE.NAMES = FALSE)\n", - " \n", - " dat_study[[\"top_loci\"]] <- dt\n", - " return(dt)\n", - " }\n", - "\n", - " ###### MAIN ######\n", - " # Process each path and collect results\n", - " orig_files = c(${\",\".join(['\"%s\"' % x.absolute() for x in _input])})\n", - " # Extract info from each RDS file\n", - " results <- list()\n", - " gene = \"${_meta_info[3]}\"\n", - " geno_ref <- \"${geno_ref}\"\n", - "\n", - " # Post Processing: Extracting info\n", - " # use for loop instead of apply to save memory\n", - " res <- res_sum <- res_minp <- cons_top_loci <- list()\n", - " pip_sum <- data.frame()\n", - " for(i in seq_along(orig_files)) {\n", - " rds_path <- orig_files[i]\n", - " dat <- tryCatch({\n", - " readRDS(rds_path)\n", - " }, error = function(e) {\n", - " writeLines(rds_path %>% basename, gsub(\".tsv\",\"_error\",\"${_output}\"))\n", - " return(NULL) # \n", - " })\n", - "\n", - " if(is.null(dat)) next\n", - " \n", - " #extract qtl type from susie rds file name, if we have set decent condtiton name, this could be removed \n", - " temp_list <- list() # Temporary list to store inner results\n", - " genes <- names(dat)\n", - " for(id in genes){\n", - " dat_study <- dat[[id]]\n", - " temp_list <- list()\n", - " if(${\"TRUE\" if mnm else \"FALSE\"}) {\n", - " if (length(dat[[id]]) <= 1) {\n", - " message(\"No multi-contexts results due to no twas results; skipping multi-context export.\")\n", - " next\n", - " }\n", - " conditions <- paste(orig_files[i] %>% basename %>% str_split(., '[.]', simplify = T) %>% .[,1],dat_study[['context_names']] %>% paste( ., collapse = ';'), sep = ':') \n", - " dat_study[['top_loci']] <- summarise_lfsr_by_marker(dat)\n", - " dat_study[['top_loci']] <- add_coef_column(dat_study)\n", - " } else conditions <- names(dat_study)[sapply(dat_study, function(x) length(x) > 0)]\n", - " \n", - " if(length(conditions) > 0) {\n", - " \n", - " for(condition in conditions) {\n", - " if (${\"FALSE\" if mnm else \"TRUE\"}) dat_con <- dat_study[[condition]]${[['fsusie_summary']] if fsusie else ''} else dat_con <- dat_study${[['fsusie_summary']] if fsusie else ''}\n", - " if (${\"TRUE\" if gwas else \"FALSE\"}){\n", - " method <- names(dat_study[[condition]])[names(dat_study[[condition]]) != 'rss_data_analyzed'] ## FIXME: this method is not showing in meta (not need if only one method). or we can use `context@method` in meta\n", - " if(length(method) == 1) dat_con <- dat_con[[method]] else stop('more than 1 method, please check.')\n", - " }\n", - " dat_susie <- dat_con$susie_result_trimmed\n", - " \n", - " # calculate the sum of pip for the vairnats with pip > 0\n", - " pip_sum = rbind(pip_sum, \n", - " data.frame(pip_sum = dat_susie[['pip']] [dat_susie[['pip']] > 0] %>% sum, \n", - " condition = condition)\n", - " )\n", - " if(${\"FALSE\" if mnm else \"TRUE\"} & has_rows(dat_con[['top_loci']])) dat_con[['top_loci']] <- dat_con[['top_loci']] %>% mutate(conditional_effect = (coef(dat_susie)/ (dat_susie[['pip']]))[variant_id])\n", - " \n", - " # rename context names if needed\n", - " if(${\"TRUE\" if condition_meta.is_file() else \"FALSE\"}){\n", - " meta <- suppressMessages(read_delim(\"${condition_meta}\", col_names = F))\n", - " context <- meta %>% filter(X1 == condition) %>% pull(X2)\n", - " if (length(context) == 0) {\n", - " context <- condition\n", - " message(\"No matching entries found. context has been set to the condition value.\")\n", - " }\n", - " } else {context <- condition}\n", - " \n", - " # align variants to aligned geno\n", - " if(has_rows(dat_con$top_loci) || has_rows(dat_con$preset_top_loci)) cons_top_loci[[id]][[context]] <- context else cons_top_loci[[id]][[context]] <- NULL \n", - " variant_ids <- c(dat_con$top_loci$variant_id, dat_con$variant_names, dat_con$preset_variants_result$top_loci$variant_id, dat_con$preset_variants_result$variant_names)\n", - " unique_variant_ids <- unique(variant_ids)\n", - " aligned_variant_ids <- align_to_genoref(unique_variant_ids, geno_ref, paste0(sub(\"^(chr)?\",\"chr\",\"${_meta_info[0]}\"), \":\", \"${_meta_info[1]}\", \"-\", \"${_meta_info[2]}\"))\n", - " names(aligned_variant_ids) <- unique_variant_ids\n", - "\n", - " # change beta or z in top loci and sumstats\n", - " top_loci_changed_indexes <- which(dat_con$top_loci$variant_id != aligned_variant_ids[dat_con$top_loci$variant_id] %>% as.character )\n", - " if(has_rows(dat_con$top_loci) & length(top_loci_changed_indexes) > 0) {\n", - " dat_con$top_loci$conditional_effect[top_loci_changed_indexes] <- (-1)* dat_con$top_loci$conditional_effect[top_loci_changed_indexes] # FIXME if coef does not need to check flip\n", - " if (${\"FALSE\" if gwas else \"TRUE\"}) {\n", - " dat_con$top_loci$betahat[top_loci_changed_indexes] <- (-1)* dat_con$top_loci$betahat[top_loci_changed_indexes]\n", - " } else {\n", - " dat_con$top_loci$z[top_loci_changed_indexes] <- (-1)* dat_con$top_loci$z[top_loci_changed_indexes]\n", - " }\n", - " }\n", - " all_changed_indexes <- which(dat_con$variant_names != aligned_variant_ids[dat_con$variant_names] %>% as.character )\n", - " if(length(all_changed_indexes) > 0) {\n", - " if (${\"FALSE\" if gwas else \"TRUE\"}) {\n", - " dat_con$sumstats$betahat[all_changed_indexes] <- (-1)* dat_con$sumstats$betahat[all_changed_indexes]\n", - " } else {\n", - " dat_con$sumstats$z[all_changed_indexes] <- (-1)* dat_con$sumstats$z[all_changed_indexes]\n", - " }\n", - " }\n", - "\n", - " # change variant names \n", - " if(has_rows(dat_con$top_loci)) dat_con$top_loci$variant_id <- aligned_variant_ids[dat_con$top_loci$variant_id] %>% as.character ###\n", - " dat_con$variant_names <- aligned_variant_ids[dat_con$variant_names] %>% as.character ###\n", - "\n", - " \n", - " if (${\"FALSE\" if gwas else \"TRUE\"}) { \n", - " res[[id]][[context]] <- list(\n", - " top_loci = process_top_loci(dat_con, dat_susie, purity_thresholds = c(${\",\".join(['\"%s\"' % x for x in min_corr])})),\n", - " pip = get_pip_withname(dat_con)\n", - " )\n", - " # the preset data in fsusie is actually from first PC and analyzed by susie, we'd like to remove them to avoid misleading\n", - " # although no preset res in mnm, we can put it here with the same layer structure. It would not report preset results\n", - " if (${\"FALSE\" if fsusie else \"TRUE\"}) {\n", - " if(has_rows(dat_con$preset_variants_result$top_loci)) {\n", - " dat_con$preset_variants_result$top_loci$variant_id <- aligned_variant_ids[dat_con$preset_variants_result$top_loci$variant_id] %>% as.character\n", - " # Calculate and add the conditional effect in one step\n", - " if(has_rows(dat_con$preset_variants_result[['top_loci']])){\n", - " dat_con$preset_variants_result[['top_loci']] <- dat_con$preset_variants_result[['top_loci']] %>%\n", - " mutate(conditional_effect = (coef(dat_con$preset_variants_result$susie_result_trimmed) /\n", - " dat_con$preset_variants_result$susie_result_trimmed[['pip']])[variant_id])\n", - " dat_con$top_loci$conditional_effect[top_loci_changed_indexes] <- (-1)* dat_con$top_loci$conditional_effect[top_loci_changed_indexes] # FIXME if coef does not need to check flip\n", - " }\n", - " }\n", - " dat_con$preset_variants_result$variant_names <- aligned_variant_ids[dat_con$preset_variants_result$variant_names] %>% as.character\n", - " # change beta in preset top loci\n", - " preset_top_loci_changed_indexes <- which(dat_con$preset_variants_result$top_loci$variant_id != aligned_variant_ids[dat_con$preset_variants_result$top_loci$variant_id] %>% as.character )\n", - " if(has_rows(dat_con$top_loci) & length(preset_top_loci_changed_indexes) > 0) dat_con$preset_variants_result$top_loci$betahat[preset_top_loci_changed_indexes] <- (-1)* dat_con$preset_variants_result$top_loci$betahat[preset_top_loci_changed_indexes] \n", - "\n", - " res[[id]][[context]][['region_info']] = dat_con$region_info\n", - " res[[id]][[context]][['CV_table']] = dat_con$twas_cv_result$performance\n", - " res[[id]][[context]][['preset_top_loci']] = process_top_loci(dat_con$preset_variants_result, dat_con$preset_variants_result$susie_result_trimmed, purity_thresholds = c(${\",\".join(['\"%s\"' % x for x in min_corr])}))\n", - " res[[id]][[context]][['preset_pip']] = get_pip_withname(dat_con$preset_variants_result)\n", - " } else {\n", - " res[[id]][[context]][['region_info']] = dat_study[[condition]]$region_info\n", - " res[[id]][[context]][['CV_table']] = dat_study[[condition]]$twas_cv_result$performance\n", - " res[[id]][[context]][['top_loci']] = annotate_susie(dat_study[[condition]], res[[id]][[context]][['top_loci']])\n", - " \n", - " } \n", - " # fsusie do not have sumstats or p value\n", - " if (${\"FALSE\" if fsusie or mnm else \"TRUE\"}) {\n", - " res_sum[[id]][[context]] <- list(\n", - " variant_names = dat_con$variant_names,\n", - " sumstats = dat_con$sumstats\n", - " )\n", - "\n", - " if (${\"FALSE\" if fsusie or mnm else \"TRUE\"}) res_minp[[id]][[context]] <- min(pecotmr:::wald_test_pval(dat_con$sumstats$betahat, dat_con$sumstats$sebetahat, n = 1000)) ##assuming sample size is 1000\n", - " }\n", - " \n", - " } else {\n", - " res[[id]][[context]][[method]] <- list(\n", - " top_loci = process_top_loci(dat_con, dat_susie, purity_thresholds = c(${\",\".join(['\"%s\"' % x for x in min_corr])})),\n", - " pip = get_pip_withname(dat_con)\n", - " )\n", - " res_sum[[id]][[context]][[method]] <- list(\n", - " variant_names = dat_con$variant_names,\n", - " sumstats = dat_con$sumstats\n", - " )\n", - "\n", - " }\n", - " \n", - "\n", - " if(has_rows(dat_con$top_loci) || has_rows(dat_con$preset_top_loci)) cons_top_loci[[id]][[context]] <- context else cons_top_loci[[id]][[context]] <- NULL\n", - " }\n", - " }\n", - " }\n", - " }\n", - "\n", - " cons_top_loci <- cons_top_loci %>% compact() # Use 'compact' to remove NULLs\n", - " cons_top_loci <- if(length(cons_top_loci) > 0) cons_top_loci else NA\n", - "\n", - " combine_data = combine_data_sumstats = cons_top_loci_minp = ''\n", - " combine_data = paste0(\"${_output:add}\",\"/\",\"${name}\", \".\", ${'\"epigenomics_\"' if fsusie else '\"\"'}, ${ '\"metabolomics_\"' if metaQTL else '\"\"'}, gene, \".cis_results_db.rds\")\n", - " if (${\"FALSE\" if fsusie else \"TRUE\"}) combine_data_sumstats = gsub(\"\\\\.rds$\", \".sumstats.rds\", combine_data)\n", - " \n", - " if (${\"TRUE\" if exported_file.is_file() else \"FALSE\"}){\n", - " if (file.exists(combine_data)) {\n", - " res_exp <- readRDS(combine_data)\n", - " res[[gene]] <- c(res[[gene]], res_exp[[gene]]) # this may need to change if tehre are multiple genes in one rds file. \n", - " }\n", - " if (file.exists(combine_data_sumstats)) {\n", - " res_sum_exp <- readRDS(combine_data_sumstats)\n", - " res_sum[[gene]] <- c(res_sum[[gene]], res_sum_exp[[gene]])\n", - " }\n", - " }\n", - " saveRDS(res, combine_data)\n", - " # only save sumstats results when NOT fsusie or multi gene mvsusie\n", - " if (${\"FALSE\" if fsusie or mnm else \"TRUE\"}) saveRDS(res_sum, combine_data_sumstats)\n", - " \n", - " # generate md5 for data transferring\n", - " system(paste(\"md5sum \",combine_data, \" > \", paste0(combine_data, \".md5\")))\n", - " if (${\"FALSE\" if fsusie or mnm else \"TRUE\"}) system(paste(\"md5sum \",combine_data_sumstats, \" > \", paste0(combine_data_sumstats, \".md5\")))\n", - " \n", - " \n", - " TSS <- tryCatch({dat_con$region_info$region_coord$start}, error = function(e) {return(NA)})\n", - " if (length(res) > 0) conditions = paste(names(res[[1]]), collapse = \",\") else conditions = ''\n", - " \n", - " # fsusie does not have sumstats or pvalue, do not need to run this\n", - "\n", - " # if (${\"FALSE\" if fsusie or gwas or mnm else \"TRUE\"}) {\n", - " # context_map <- process_and_match_contexts('${context_meta}', cons_top_loci, res_minp)\n", - " # context_map$context_df_with_order <- process_lf2_cluster(context_map$context_df_with_order)\n", - " # cons_top_loci_minp <- combine_order(context_map$context_df_no_order, context_map$context_df_with_order)\n", - " # }\n", - "\n", - " # save pip sum file \n", - " write_delim(pip_sum, \n", - " paste0(\"${_output:add}\",\"/\",\"${name}\", \".\", ${'\"epigenomics_\"' if fsusie else '\"\"'}, ${ '\"metabolomics_\"' if metaQTL else '\"\"'}, gene, \".pip_sum\"), \n", - " delim = '\\t')\n", - "\n", - " meta = data.frame(chr=\"${_meta_info[0]}\", start=\"${_meta_info[1]}\", end=\"${_meta_info[2]}\", region_id=\"${_meta_info[3]}\", TSS = if(is.null(TSS)) NA else TSS, \n", - " original_data = paste(basename(orig_files), collapse = \",\"), combined_data = basename(combine_data), combined_data_sumstats = basename(combine_data_sumstats), \n", - " conditions = conditions, \n", - " conditions_top_loci = if(length(cons_top_loci) > 0) cons_top_loci[[1]] %>% unlist %>% names %>% as.character %>% paste(., collapse = ',') else ''\n", - " # , conditions_top_loci_minp = if(length(cons_top_loci_minp) > 0) cons_top_loci_minp %>% paste(., collapse = ',') else ''\n", - " )\n", - "\n", - " write_delim(meta, \"${_output}\", delim = '\\t')\n", - " " + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container, entrypoint = entrypoint\n", + " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_cis_db_export.R \\\n", + " --input ${_input} \\\n", + " --combined-data-output ${cwd}/${name}.${_meta_info[3]}.${_db_kind}.rds \\\n", + " ${('--combined-data-sumstats-output %s/%s.%s.%s.sumstats.rds' % (cwd, name, _meta_info[3], _db_kind)) if not (fsusie or mnm) else ''} \\\n", + " --region-id ${_meta_info[3]} --chr ${_meta_info[0]} --start ${_meta_info[1]} --end ${_meta_info[2]} \\\n", + " --signal-cutoff ${pip_thres} ${_purity_arg} \\\n", + " --meta-output ${_output} \\\n", + " --pip-sum-output ${cwd}/${name}.${_meta_info[3]}.pip_sum\n" ] }, { @@ -2106,143 +950,37 @@ "outputs": [], "source": [ "[export_top_loci_2]\n", + "# Export the per-region top-loci BED from each cis_results_db (an FMR in the\n", + "# modern pipeline) via the pecotmr-backed fine_mapping_top_loci_bed.R wrapper.\n", + "# getTopLoci does the PIP/CS + independent purity filtering; lfsr /\n", + "# conditional_effect are per-(variant, context) numeric columns, so the legacy\n", + "# filter_lfsr semicolon split/rejoin is gone.\n", "# `export_suffix` deliberately differs from step 1's `--suffix` (input rds) to avoid CLI collision.\n", "parameter: export_path = cwd\n", "parameter: export_prefix = '' # falls back to step-1 `name` if empty\n", "parameter: export_suffix = 'cis_results_db.rds'\n", "parameter: fsusie_prefix = ''\n", "parameter: preset_top_loci = False\n", + "# PIP cutoff for getTopLoci; optional independent CS purity (min.abs.corr) cutoff (<0 => none).\n", + "parameter: signal_cutoff = 0.025\n", + "parameter: min_purity = -1.0\n", + "# Retained for CLI compatibility; lfsr is now a per-variant column (no split/rejoin).\n", "parameter: lfsr_thres = 0.01\n", "\n", "_pfx = export_prefix if export_prefix else name\n", "import glob as _glob\n", "_rds_files = sorted(_glob.glob(f\"{export_path}/{_pfx}.{fsusie_prefix}*.{export_suffix}\"))\n", "stop_if(len(_rds_files) == 0, f\"No RDS files matched: {export_path}/{_pfx}.{fsusie_prefix}*.{export_suffix}\")\n", + "_purity_arg = f\"--min-purity {min_purity}\" if float(min_purity) >= 0 else \"\"\n", "\n", "input: _rds_files, group_by = 1\n", "output: f\"{cwd}/summary/{_input:bnn}.top_loci.bed.gz\"\n", "task: trunk_workers = 1, walltime = '1h', trunk_size = job_size, mem = '16G', cores = 1, tags = f'{_output:bn}'\n", - "R: expand = \"${ }\", container = container, stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout'\n", - " library(tidyverse)\n", - " library(data.table)\n", - " lfsr_thres <- as.numeric(${lfsr_thres})\n", - " #function to filter lfsr\n", - " filter_lfsr <- function(df, lfsr_thres){\n", - " df_na <- df %>% filter(is.na(lfsr)|lfsr == '') %>% mutate(event_ID = NA)\n", - " df %>%\n", - " mutate(\n", - " lfsr_list = str_split(lfsr, \";\") %>% map(as.numeric),\n", - " effect_list = str_split(conditional_effect, \";\"),\n", - " event_list = str_split(event_ID, \";\"),\n", - " valid_indices = map(lfsr_list, ~ which(.x < lfsr_thres))\n", - " ) %>%\n", - " rowwise() %>%\n", - " mutate(\n", - " event_ID = paste(event_list[valid_indices], collapse = \";\"),\n", - " conditional_effect = paste(effect_list[valid_indices], collapse = \";\"),\n", - " lfsr = paste(lfsr_list[valid_indices], collapse = \";\")\n", - " ) %>%\n", - " filter(event_ID != \"\") %>%\n", - " select(any_of(colnames(file_top_loci_rename))) %>%\n", - " ungroup() %>% rbind(df, df_na)\n", - " }\n", - " \n", - " ## main\n", - " res <- readRDS(\"${_input}\")\n", - " file_top_loci <- lapply(names(res), function(gene) {\n", - " lapply(names(res[[gene]]), function(context) {\n", - " lapply(c(\"top_loci\"${',\"preset_top_loci\"' if preset_top_loci else ''}), function(method) {\n", - " if (\"RSS_QC_RAISS_imputed\" %in% names(res[[gene]][[context]])) { # that is for rss output\n", - " temp_df <- res[[gene]][[context]][['RSS_QC_RAISS_imputed']][[method]]\n", - " } else {\n", - " temp_df <- res[[gene]][[context]][[method]]\n", - " }\n", - " if (!is.null(temp_df)) {\n", - " mutate(temp_df, study = context, method = method, region = gene)\n", - " } else {\n", - " NULL \n", - " }\n", - " })\n", - " }) %>% bind_rows() \n", - " }) %>% bind_rows() \n", - "\n", - " # Check if file_top_loci is not empty before processing\n", - " if (!is.null(file_top_loci) && nrow(file_top_loci) > 0) {\n", - " file_top_loci_rename <- file_top_loci %>% \n", - " # Select necessary columns from the original table\n", - " select(any_of(c(\n", - " \"variant_id\", \"pip\", \n", - " \"cs_coverage_0.95_min_corr\",\"cs_coverage_0.7_min_corr\", \"cs_coverage_0.5_min_corr\",\n", - " \"cs_coverage_0.95_min_corr_0.8\",\"cs_coverage_0.7_min_corr_0.8\", \"cs_coverage_0.5_min_corr_0.8\",\n", - " \"cs_coverage_0.95_min_corr_0.5\",\"cs_coverage_0.7_min_corr_0.5\", \"cs_coverage_0.5_min_corr_0.5\",\n", - " \"study\", \"method\", \"region\", \"conditional_effect\", \"lfsr\", \"trait\", \"maf\", \"betahat\", \"sebetahat\", \"z\"\n", - " \n", - " ))) %>% \n", - " mutate(\n", - " # Split variant_id into separate components\n", - " chr = str_split(variant_id, \":\", simplify = TRUE)[, 1], # Chromosome\n", - " pos = str_split(variant_id, \":\", simplify = TRUE)[, 2], # Position\n", - " a1 = str_split(variant_id, \":\", simplify = TRUE)[, 4], # Allele 1\n", - " a2 = str_split(variant_id, \":\", simplify = TRUE)[, 3], # Allele 2\n", - " # Rename and duplicate columns as required\n", - " variant_ID = variant_id,\n", - " gene_ID = region,\n", - " event_ID = study,\n", - " PIP = pip,\n", - " MAF = maf,\n", - " betahat = betahat,\n", - " sebetahat = sebetahat,\n", - " z = if (\"z\" %in% colnames(.)) z else NA,\n", - " \n", - " ) %>%\n", - " {\n", - " if (any(c(\"cs_coverage_0.95_min_corr_0.8\", \"cs_coverage_0.7_min_corr_0.8\", \"cs_coverage_0.5_min_corr_0.8\", \n", - " \"cs_coverage_0.95_min_corr_0.5\", \"cs_coverage_0.7_min_corr_0.5\", \"cs_coverage_0.5_min_corr_0.5\", \n", - " \"cs_coverage_0.95_min_corr\", \"cs_coverage_0.7_min_corr\", \"cs_coverage_0.5_min_corr\") %in% colnames(.))) {\n", - " mutate(.,\n", - " cs_coverage_0.95 = if (\"cs_coverage_0.95_min_corr_0.8\" %in% colnames(.)) get(\"cs_coverage_0.95_min_corr_0.8\") else \n", - " if (\"cs_coverage_0.95_min_corr\" %in% colnames(.)) get(\"cs_coverage_0.95_min_corr\") else NA,\n", - "\n", - " cs_coverage_0.7 = if (\"cs_coverage_0.7_min_corr_0.8\" %in% colnames(.)) get(\"cs_coverage_0.7_min_corr_0.8\") else \n", - " if (\"cs_coverage_0.7_min_corr\" %in% colnames(.)) get(\"cs_coverage_0.7_min_corr\") else NA,\n", - "\n", - " cs_coverage_0.5 = if (\"cs_coverage_0.5_min_corr_0.8\" %in% colnames(.)) get(\"cs_coverage_0.5_min_corr_0.8\") else \n", - " if (\"cs_coverage_0.5_min_corr\" %in% colnames(.)) get(\"cs_coverage_0.5_min_corr\") else NA,\n", - "\n", - " cs_coverage_0.95_purity0.5 = if (\"cs_coverage_0.95_min_corr_0.5\" %in% colnames(.)) get(\"cs_coverage_0.95_min_corr_0.5\") else NA,\n", - " cs_coverage_0.7_purity0.5 = if (\"cs_coverage_0.7_min_corr_0.5\" %in% colnames(.)) get(\"cs_coverage_0.7_min_corr_0.5\") else NA,\n", - " cs_coverage_0.5_purity0.5 = if (\"cs_coverage_0.5_min_corr_0.5\" %in% colnames(.)) get(\"cs_coverage_0.5_min_corr_0.5\") else NA\n", - " )\n", - " } else .\n", - " } %>%\n", - " # Conditionally add lfsr if the column exists\n", - " mutate(region_id = basename(\"${_input}\") %>% str_split(., '[.]', simplify = T) %>% .[,2]) %>% \n", - " # Conditionally add lfsr if the column exists\n", - " { if (\"lfsr\" %in% colnames(.)) mutate(., lfsr = lfsr, context = str_split(event_ID, ':', simplify = T) %>% .[,1]) else . } %>% \n", - " { if (\"lfsr\" %in% colnames(.) & lfsr_thres != 0) mutate(., event_ID = trait) else . } %>% \n", - " # Select and order the final set of columns\n", - " select(any_of(c(\"chr\", \"pos\", \"a1\", \"a2\", \"variant_ID\", \"MAF\", \"betahat\", \"sebetahat\", \"z\", \"gene_ID\", \"event_ID\",\n", - " \"cs_coverage_0.95\", \"cs_coverage_0.7\", \"cs_coverage_0.5\",\n", - " \"cs_coverage_0.95_purity0.5\", \"cs_coverage_0.7_purity0.5\", \"cs_coverage_0.5_purity0.5\", \"PIP\", \"conditional_effect\", \n", - " \"lfsr\", \"region_id\", \"context\"${'\",method\"' if preset_top_loci else ''}))) %>% \n", - " # Sort by chromosome and position (convert pos to numeric if necessary)\n", - " arrange(chr, as.numeric(pos))\n", - " # Check if \"lfsr\" is in column names\n", - " if (\"lfsr\" %in% colnames(file_top_loci_rename) & lfsr_thres != 0) file_top_loci_rename <- filter_lfsr(file_top_loci_rename, lfsr_thres = lfsr_thres)\n", - " fwrite(file_top_loci_rename,\"${_output}\")\n", - " } else {\n", - " # Create empty output if input is empty or NULL\n", - " cat(\"Input data is empty. Creating empty output file.\\n\")\n", - "\n", - " # Create an empty data frame with the expected column structure\n", - " empty_df <- data.frame(\n", - " chr = character(0),\n", - " pos = character(0)\n", - " )\n", - "\n", - " # Write empty file\n", - " fwrite(empty_df,\"${_output}\")\n", - " }\n" + "bash: expand = \"${ }\", container = container, stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', entrypoint=entrypoint\n", + " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_top_loci_bed.R \\\n", + " --input ${_input} \\\n", + " --signal-cutoff ${signal_cutoff} ${_purity_arg} \\\n", + " --output ${_output}\n" ] }, { @@ -2310,201 +1048,59 @@ "parameter: qtl_meta_path = path()\n", "parameter: gwas_file_path = ''\n", "parameter: qtl_file_path = ''\n", - "# Optional: if a region list is provide the analysis will be focused on provided region. \n", - "# The LAST column of this list will contain the ID of regions to focus on\n", - "# Otherwise, all regions with both genotype and phenotype files will be analyzed\n", + "# Optional: focus on a region list (last column = region id) and/or region names.\n", "parameter: region_list = path()\n", - "# Optional: if a region name is provided \n", - "# the analysis would be focused on the union of provides region list and region names\n", "parameter: region_name = []\n", - "import pandas as pd\n", - "import numpy as np\n", - "from pathlib import Path\n", - "\n", - "if qtl_file_path == '':\n", - " qtl_file_path = qtl_meta_path.parent\n", - "if gwas_file_path == '':\n", - " gwas_file_path = gwas_meta_path.parent\n", - " \n", - "# Load the data, suppressing messages is not typically done in pandas as it does not inherently output messages when loading files\n", - "gwas_meta = pd.read_csv(gwas_meta_path, sep='\\t', low_memory=False)\n", - "gwas_meta = gwas_meta[gwas_meta['conditions_top_loci'].notna()]\n", - "\n", - "qtl_meta = pd.read_csv(qtl_meta_path, sep='\\t', low_memory=False)\n", - "qtl_meta = qtl_meta[qtl_meta['conditions_top_loci'].notna()]\n", - "\n", - "# Filter and mutate operations, translated to pandas\n", - "gwas_meta['combined_data_toploci'] = gwas_meta.apply(lambda row: row['combined_data'] if pd.notnull(row['conditions_top_loci']) else pd.NA, axis=1)\n", - "\n", - "region_ids=[]\n", - "# If region_list is provided, read the file and extract IDs\n", - "if not region_list.is_dir():\n", - " if region_list.is_file():\n", - " region_list_df = pd.read_csv(region_list, sep='\\t', header=None, comment = \"#\")\n", - " region_ids = region_list_df.iloc[:, -1].unique() # Extracting the last column for IDs\n", - " else:\n", - " raise ValueError(\"The region_list path provided is not a file.\")\n", - " \n", - "if len(region_name) > 0:\n", - " region_ids = list(set(region_ids).union(set(region_name)))\n", - " \n", - "if len(region_ids) > 0:\n", - " qtl_meta = qtl_meta[qtl_meta['region_id'].isin(region_ids)]\n", - " \n", - "def group_by_region(lst, partition):\n", - " # from itertools import accumulate\n", - " # partition = [len(x) for x in partition]\n", - " # Compute the cumulative sums once\n", - " # cumsum_vector = list(accumulate(partition))\n", - " # Use slicing based on the cumulative sums\n", - " # return [lst[(cumsum_vector[i-1] if i > 0 else 0):cumsum_vector[i]] for i in range(len(partition))]\n", - " return partition\n", - "\n", - "grouped_gwas_meta = {k: v for k, v in gwas_meta.groupby('#chr')}\n", - "def check_overlap(gene_row, grouped_gwas_meta):\n", - " chr_group = gene_row['#chr']\n", - " if chr_group in grouped_gwas_meta:\n", - " block_region = grouped_gwas_meta[chr_group]\n", - " overlaps = block_region[\n", - " (block_region['start'] <= gene_row['end']) &\n", - " (block_region['end'] >= gene_row['start'])\n", - " ]\n", - " if not overlaps.empty:\n", - " return ','.join(overlaps['combined_data_toploci'].astype(str))\n", - " return pd.NA\n", - "\n", - "stop_if(len(qtl_meta) == 0, f'No file left for analysis ')\n", - "\n", - "qtl_meta_cand = qtl_meta.apply(lambda row: pd.Series({\n", - " 'gwas_file': check_overlap(row, grouped_gwas_meta)\n", - "}), axis=1)\n", - "\n", - "# Concatenate the new columns to the original qtl_meta DataFrame\n", - "qtl_meta_cand = pd.concat([qtl_meta, qtl_meta_cand], axis=1)\n", - "qtl_meta_filtered = qtl_meta_cand[qtl_meta_cand['gwas_file'].notna()]\n", - "qtl_meta_filtered = qtl_meta_filtered.dropna(subset=['gwas_file'])\n", - "\n", - "\n", - "regional_data = {\n", - " 'meta': [(row['#chr'], row['start'], row['end'], row['region_id'], row['gwas_file'].split(',')) for _, row in qtl_meta_filtered.iterrows()],\n", - " 'qtl_data': [f\"{qtl_file_path}/{row['combined_data']}\" for _, row in qtl_meta_filtered.iterrows()]\n", - "}\n", - "\n", - "meta_info = regional_data['meta']\n", - "stop_if(len(regional_data['qtl_data']) == 0, f'No file left for analysis ')\n", - "\n", - "input: regional_data[\"qtl_data\"], group_by = lambda x: group_by_region(x, regional_data[\"qtl_data\"]), group_with = \"meta_info\"\n", + "# PIP cutoff for the top-loci overlap. 0 = intersect all top-loci variants (the\n", + "# legacy behaviour, which had its CS filter commented out); the coarse block\n", + "# pairing that feeds coloc wants breadth, not just the strongest signal.\n", + "parameter: signal_cutoff = 0.0\n", + "# Orchestration only (no pandas / no helper defs): pair each QTL region with the\n", + "# GWAS blocks it overlaps by coordinate, resolving both sides' original_data\n", + "# (per-study/per-block S4 FineMappingResult files). fine_mapping_overlap.R does\n", + "# the allele-aware variant overlap + stamps block_top_loci onto the meta row.\n", + "import os, csv\n", + "\n", + "if qtl_file_path == '': qtl_file_path = str(qtl_meta_path.parent)\n", + "if gwas_file_path == '': gwas_file_path = str(gwas_meta_path.parent)\n", + "\n", + "_hasTop = lambda r: (r.get('conditions_top_loci') or '').strip() not in ('', 'NA')\n", + "_g = [r for r in csv.DictReader(open(gwas_meta_path), delimiter='\\t') if _hasTop(r)]\n", + "_q = [r for r in csv.DictReader(open(qtl_meta_path), delimiter='\\t') if _hasTop(r)]\n", + "\n", + "_focus = set(region_name)\n", + "if region_list.is_file():\n", + " _focus |= {l.rstrip('\\n').split('\\t')[-1] for l in open(region_list) if l.strip() and not l.startswith('#')}\n", + "if len(_focus) > 0:\n", + " _q = [r for r in _q if r['region_id'] in _focus or f\"{r['#chr']}_{r['region_id']}\" in _focus]\n", + "\n", + "_meta = []\n", + "_qtl_data = []\n", + "for q in _q:\n", + " qchr, qs, qe = q['#chr'], int(q['start']), int(q['end'])\n", + " blocks = [g for g in _g if g['#chr'] == qchr and int(g['start']) <= qe and int(g['end']) >= qs]\n", + " gfiles = [f\"{gwas_file_path}/{x.strip()}\" for g in blocks for x in g['original_data'].split(',') if x.strip()]\n", + " gfiles = [f for f in gfiles if os.path.exists(f)]\n", + " qfiles = [f\"{qtl_file_path}/{x.strip()}\" for x in q['original_data'].split(',') if x.strip()]\n", + " qfiles = [f for f in qfiles if os.path.exists(f)]\n", + " if gfiles and qfiles:\n", + " _meta.append((qchr, q['start'], q['end'], q['region_id'], gfiles))\n", + " _qtl_data.append(qfiles)\n", + "\n", + "stop_if(len(_qtl_data) == 0, 'No overlapping QTL x GWAS region pairs with existing files.')\n", + "meta_info = _meta\n", + "\n", + "input: [f for grp in _qtl_data for f in grp], group_by = lambda x: _qtl_data, group_with = \"meta_info\"\n", "output: f\"{cwd}/gwas_qtl/cache/{name}_gwas_batch_meta_{_meta_info[3]}.tsv\"\n", "task: trunk_workers = 1, walltime = '1h', trunk_size = job_size, mem = '16G', cores = 1, tags = f'{_output:bn}'\n", - "R: expand = \"${ }\", container = container, stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout'\n", - " library(tidyverse)\n", - " library(plyr)\n", - " library(data.table)\n", - "\n", - " # Function to add 'chr' in variants\n", - " add_chr_prefix <- function(var) {\n", - " if (any(grepl(\"chr\", var))) {\n", - " var <- var\n", - " } else {\n", - " var <- paste0(\"chr\", var)\n", - " }\n", - " return(var)\n", - " }\n", - "\n", - " # Function to check if a dataframe has rows\n", - " has_rows <- function(df) {\n", - " !is.null(df) && nrow(df) > 0\n", - " }\n", - "\n", - "\n", - " extract_top_loci <- function(res, include_method = FALSE) {\n", - " all_top_loci <- lapply(names(res), function(region) {\n", - " lapply(names(res[[region]]), function(study) {\n", - " if (include_method) {\n", - " method_results <- lapply(names(res[[region]][[study]]), function(method) {\n", - " top_loci <- NULL\n", - " if (!is.null(res[[region]][[study]][[method]]$top_loci) && nrow(res[[region]][[study]][[method]]$top_loci) > 0) {\n", - " top_loci <- mutate(res[[region]][[study]][[method]]$top_loci, study = study, method = method, region = region)\n", - " }\n", - " return(top_loci)\n", - " })\n", - " return(bind_rows(method_results))\n", - " } else {\n", - " top_loci <- list()\n", - " if (!is.null(res[[region]][[study]]$top_loci) && nrow(res[[region]][[study]]$top_loci) > 0) {\n", - " top_loci[[length(top_loci) + 1]] <- mutate(res[[region]][[study]]$top_loci, study = study, region = region, method = 'top_loci')\n", - " }\n", - " if (!is.null(res[[region]][[study]]$preset_top_loci) && nrow(res[[region]][[study]]$preset_top_loci) > 0) {\n", - " top_loci[[length(top_loci) + 1]] <- mutate(res[[region]][[study]]$preset_top_loci, study = study, region = region, method = 'preset_top_loci')\n", - " }\n", - " return(bind_rows(top_loci))\n", - " }\n", - " })\n", - " }) %>% bind_rows() %>% na.omit()\n", - "\n", - " return(all_top_loci)\n", - " }\n", - "\n", - " \n", - " # load data \n", - " qtl_file = c(${\",\".join(['\"%s\"' % x.absolute() for x in _input])})\n", - " # Extract info from each RDS file\n", - " gwas_files = c(${\",\".join('\"%s\"' % x for x in _meta_info[4])}) %>% paste0('${gwas_file_path}','/',.)\n", - " # Process GWAS files\n", - " gwas_all_top_loci <- do.call(rbind.fill, lapply(gwas_files, function(file) {\n", - " res <- readRDS(file)\n", - " gwas_all_top_loci <- extract_top_loci(res, include_method = TRUE) \n", - " }))\n", - " if(!is.null(gwas_all_top_loci) && nrow(gwas_all_top_loci) > 0){# fixme: could remove this judge if we get a solid enough meta\n", - " gwas_all_top_loci <- gwas_all_top_loci%>% select(-c('z'))\n", - "\n", - " # Process QTL file\n", - " qtl <- readRDS(qtl_file)\n", - " qtl_all_top_loci <- extract_top_loci(qtl) \n", - " if(!is.null(qtl_all_top_loci) && nrow(qtl_all_top_loci) > 0){# fixme: could remove this judge if we get a solid enough meta\n", - " # qtl_all_top_loci <- qtl_all_top_loci%>% select(-c('betahat','sebetahat','maf'))\n", - "\n", - " cs_cal <- c('cs_coverage_0.95','cs_coverage_0.7','cs_coverage_0.5')\n", - "\n", - " qtl_all_var <- qtl_all_top_loci %>%\n", - " #filter(rowSums(.[,cs_cal]) > 0 ) %>% #fixme\n", - " pull(variant_id)\n", - "\n", - " gwas_all_var <- gwas_all_top_loci %>%\n", - " #filter(rowSums(.[,cs_cal]) > 0 ) %>% #fixme\n", - " pull(variant_id)\n", - "\n", - " gwas_all_var <- if(any(grepl(\"chr\", qtl_all_var))) add_chr_prefix(gwas_all_var) else gsub(\"chr\", \"\", gwas_all_var)\n", - " gwas_all_top_loci$variant_id <- gwas_all_var\n", - " # since both qtl and gwas haven mapped to geno ref in exporting, here we intersect them directly\n", - " int_var <- intersect(qtl_all_var, gwas_all_var)\n", - " if(length(int_var) > 0){\n", - " gwas_all_top_loci <- gwas_all_top_loci %>% filter(variant_id %in% int_var) # fixme: keep all gwas variants or intersected ones\n", - "\n", - " all_top_loci <- rbind.fill(gwas_all_top_loci, qtl_all_top_loci)\n", - " fwrite(all_top_loci, gsub('_gwas_batch_meta','_gwas_batch_export',${_output:r}))\n", - "\n", - " new_gwas <- split(gwas_all_top_loci, gwas_all_top_loci$study)\n", - " new_gwas <- lapply(new_gwas, function(df) {\n", - " split(df, df$method)\n", - " })\n", - "\n", - " qtl[[1]] <- c(qtl[[1]], new_gwas)\n", - " new_qtl_path <- paste0(${_output:ddr},\"/\",gsub(\".rds\",\".overlapped.gwas.rds\",basename(qtl_file)))\n", - " saveRDS(qtl, new_qtl_path)\n", - " \n", - " block_top_loci = gwas_all_top_loci$region %>% unique %>% paste(., collapse = ',')\n", - " final_combined_data = new_qtl_path %>% basename\n", - " } else {block_top_loci = final_combined_data = NA} # fixme: could remove this judge if we get a solid enough meta\n", - " } else {block_top_loci = final_combined_data = NA} # fixme: could remove this judge if we get a solid enough meta\n", - " } else {\n", - " block_top_loci = final_combined_data = NA\n", - " }\n", - " \n", - " qtl_meta <- suppressMessages(read_delim('${qtl_meta_path}'))\n", - " qtl_meta <- qtl_meta %>% filter(region_id == '${_meta_info[3]}') %>% mutate(block_top_loci = block_top_loci,\n", - " final_combined_data = final_combined_data)\n", - " fwrite(qtl_meta, ${_output:r})" + "bash: expand = \"${ }\", container = container, stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout'\n", + " Rscript code/script/pecotmr_integration/fine_mapping_overlap.R \\\n", + " --qtl ${\" \".join([str(x) for x in _input])} \\\n", + " --gwas ${\" \".join(_meta_info[4])} \\\n", + " --signal-cutoff ${signal_cutoff} \\\n", + " --qtl-meta ${qtl_meta_path} --region-id ${_meta_info[3]} \\\n", + " --meta-output ${_output} \\\n", + " --output ${cwd}/gwas_qtl/cache/${name}_gwas_batch_export_${_meta_info[3]}.tsv\n" ] }, { diff --git a/code/SoS/multivariate_genome/MASH/mash_fit.ipynb b/code/SoS/multivariate_genome/MASH/mash_fit.ipynb index cf705d0f6..37b4f72db 100644 --- a/code/SoS/multivariate_genome/MASH/mash_fit.ipynb +++ b/code/SoS/multivariate_genome/MASH/mash_fit.ipynb @@ -168,11 +168,7 @@ "if len(output_prefix) == 0:\n", " output_prefix = f\"{data:bn}\"\n", "\n", - "mash_model = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.mash_model.rds\")\n", - "\n", - "def sort_uniq(seq):\n", - " seen = set()\n", - " return [x for x in seq if not (x in seen or seen.add(x))]" + "mash_model = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.mash_model.rds\")" ] }, { @@ -196,20 +192,21 @@ }, "outputs": [], "source": [ - "# Fit MASH mixture model (time estimate: <15min for 70K by 49 matrix)\n", + "# Fit MASH mixture model (learns the mixture weights on the random subset)\n", "[mash_1]\n", "parameter: output_level = 4\n", "input: data, vhat_data, prior_data\n", "output: mash_model\n", "\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " library(mashr)\n", - " dat = readRDS(${_input[0]:r})\n", - " vhat = readRDS(${_input[1]:r})\n", - " U = readRDS(${_input[2]:r})$U\n", - " mash_data = mash_set_data(dat$random.b, Shat=dat$random.s, alpha=${1 if effect_model == 'EZ' else 0}, V=vhat, zero_Bhat_Shat_reset = 1E3)\n", - " saveRDS(list(mash_model = mash(mash_data, Ulist = U, outputlevel = ${output_level}), vhat_file=${_input[1]:r}, prior_file=${_input[2]:r}), ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_fit.R \\\n", + " --data ${_input[0]} \\\n", + " --vhat-data ${_input[1]} \\\n", + " --prior-data ${_input[2]} \\\n", + " --effect-model ${effect_model} \\\n", + " --output-level ${output_level} \\\n", + " --output ${_output}" ] }, { @@ -239,7 +236,7 @@ "outputs": [], "source": [ "# Compute posterior for the \"strong\" set of data as in Urbut et al 2017.\n", - "# This is optional because most of the time we want to apply the \n", + "# This is optional because most of the time we want to apply the\n", "# MASH model learned on much larger data-set.\n", "[mash_2]\n", "# default to True; use --no-compute-posterior to disable this\n", @@ -250,14 +247,14 @@ "input: data, vhat_data, mash_model\n", "output: f\"{cwd:a}/{output_prefix}.{effect_model}.posterior.rds\"\n", "\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " library(mashr)\n", - " dat = readRDS(${_input[0]:r})\n", - " vhat = readRDS(${_input[1]:r})\n", - " mash_data = mash_set_data(dat$strong.b, Shat=dat$strong.s, alpha=${1 if effect_model == 'EZ' else 0}, V=vhat, zero_Bhat_Shat_reset = 1E3)\n", - " mash_model = readRDS(${_input[2]:ar})$mash_model\n", - " saveRDS(mash_compute_posterior_matrices(mash_model, mash_data), ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_posterior.R \\\n", + " --data ${_input[0]} \\\n", + " --vhat-data ${_input[1]} \\\n", + " --mash-model ${_input[2]} \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] } ], @@ -309,4 +306,4 @@ }, "nbformat": 4, "nbformat_minor": 4 -} \ No newline at end of file +} diff --git a/code/SoS/multivariate_genome/MASH/mash_posterior.ipynb b/code/SoS/multivariate_genome/MASH/mash_posterior.ipynb index f2562f2e7..d844ae17f 100644 --- a/code/SoS/multivariate_genome/MASH/mash_posterior.ipynb +++ b/code/SoS/multivariate_genome/MASH/mash_posterior.ipynb @@ -253,7 +253,39 @@ "kernel": "SoS" }, "outputs": [], - "source": "[global]\nimport os\n# Work directory & output directory\nparameter: cwd = path('./')\n# The filename prefix for output data\nparameter: name=\"test\"\nparameter: cells = [\"Ast\",\"Exc\",\"Inh\",\"Mic\",\"OPC\",\"Oli\",\"DLPFC_pQTL\"]#order is important\nparameter: group1 = []\nparameter: group2 = []\nparameter: group3 = []\nparameter: job_size = 1\nparameter: container = ''\n# handle N = per_chunk data-set in one job\nparameter: per_chunk = 1\n###add for test\nparameter: output_prefix = ''\nparameter: output_suffix = 'all'\n# Exchangable effect (EE) or exchangable z-scores (EZ)\nparameter: effect_model = 'EE'\n# Identifier of $\\hat{V}$ estimate file\n# Options are \"identity\", \"simple\", \"mle\", \"vhat_corshrink_xcondition\", \"vhat_simple_specific\"\nparameter: vhat = 'simple'\nparameter: data = path(\"fastqtl_to_mash_output/FastQTLSumStats.mash.rds\")\nparameter: p_cut=0.00001\n\nimport pandas as pd\ndata = data.absolute()\ncwd = cwd.absolute()\n\nif len(output_prefix) == 0:\n output_prefix = f\"{data:bn}\"\nvhat_data = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.V_{vhat}.rds\")\nmash_model = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.V_{vhat}.mash_model.rds\")\nposterior_list = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.{output_suffix}.posterior_list\")\n\ndef sort_uniq(seq):\n seen = set()\n return [x for x in seq if not (x in seen or seen.add(x))]" + "source": [ + "[global]\n", + "parameter: cwd = path('./output')\n", + "parameter: name = 'test'\n", + "# Conditions (contexts); order matters\n", + "parameter: cells = []\n", + "# Condition groups: replicate populations of one cell type share contrast weight\n", + "parameter: group1 = []\n", + "parameter: group2 = []\n", + "parameter: group3 = []\n", + "parameter: job_size = 1\n", + "parameter: container = ''\n", + "# Number of analysis units per job\n", + "parameter: per_chunk = 1\n", + "parameter: output_prefix = ''\n", + "parameter: output_suffix = 'all'\n", + "# Exchangable effect (EE) or exchangable z-scores (EZ)\n", + "parameter: effect_model = 'EE'\n", + "# Vhat estimate identifier (e.g. simple / identity / mle)\n", + "parameter: vhat = 'simple'\n", + "parameter: data = path(\"fastqtl_to_mash_output/FastQTLSumStats.mash.rds\")\n", + "# Significance cutoff for the contrast summary / n-sig feature score\n", + "parameter: p_cut = 0.00001\n", + "parameter: walltime = '1h'\n", + "parameter: mem = '16G'\n", + "parameter: numThreads = 1\n", + "data = data.absolute()\n", + "cwd = cwd.absolute()\n", + "if len(output_prefix) == 0:\n", + " output_prefix = f\"{data:bn}\"\n", + "vhat_data = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.V_{vhat}.rds\")\n", + "mash_model = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.V_{vhat}.mash_model.rds\")" + ] }, { "cell_type": "markdown", @@ -283,7 +315,31 @@ "kernel": "SoS" }, "outputs": [], - "source": "# Apply posterior calculations with slice NA and set NaN/Inf 0/1E3, output_posterior_cov = T \n[posterior_1]\nparameter: analysis_units = path\nregions = [x.replace(\"\\\"\",\"\").strip().split() for x in open(analysis_units).readlines() if x.strip() and not x.strip().startswith('#')]\nparameter: mash_model = path()\nmash_model = mash_model.absolute()\nparameter: posterior_input = [path(x[0]) for x in regions]\nparameter: posterior_vhat_files = paths()\nposterior_vhat_files = paths([x.absolute() for x in posterior_vhat_files])\n# eg, if data is saved in R list as data$strong, then\n# when you specify `--data-table-name strong` it will read the data as\n# readRDS('{_input:r}')$strong\nparameter: data_table_name = ''\nparameter: bhat_table_name = 'bhat'\nparameter: shat_table_name = 'sbhat'\nparameter: per_chunk = '100'\n## conditions can be excluded if needs arise. If nothing to exclude keep the default 0\nparameter: exclude_condition = [\"1\",\"3\"]\n\nparameter: slice_method = False \nskip_if(len(posterior_input) == 0, msg = \"No posterior input data to compute on. Please specify it using --posterior-input.\")\nfail_if(len(posterior_vhat_files) > 1 and len(posterior_vhat_files) != len(posterior_input), msg = \"length of --posterior-input and --posterior-vhat-files do not agree.\")\nfor p in posterior_input:\n fail_if(not p.is_file(), msg = f'Cannot find posterior input file ``{p}``')\n\ninput: posterior_input, group_by = per_chunk\noutput: f\"{cwd}/cache/mash_output_list_{_index+1}\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \nR: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n library(mashr)\n library(dplyr)\n library(stringr)\n #library(ttt)\n handle_nan_etc = function(x) {\n x$bhat[which(is.nan(x$bhat))] = 0\n x$sbhat[which(is.nan(x$sbhat) | is.infinite(x$sbhat))] = 1E3\n return(x)\n }\n # Slice matrices\n slice_and_update_data <- function(data, vhat, snps, samples) {\n data$bhat <- data$bhat[snps, samples] %>% as.matrix\n data$sbhat <- data$sbhat[snps, samples] %>% as.matrix\n data$Z <- data$Z[snps, samples] %>% as.matrix\n vhat <- vhat[samples, samples] %>% as.matrix\n\n # Filter SNPs and update column names\n data$snp <- data$snp[data$snp %in% snps]\n colnames(data$bhat) <- colnames(data$sbhat) <- colnames(data$Z) <- colnames(vhat) <- samples\n\n return(list(data = data, vhat = vhat))\n }\n \n # Remove covariance matrices that are not needed\n remove_unnecessary_cov_matrices <- function(cov, all_samples, samples) {\n unwanted_samples <- setdiff(all.samples, samples)\n for (d in names(cov)) {\n if (d %in% unwanted_samples || d %in% paste0(\"ED_\", unwanted_samples)) {\n cov[[d]] <- NULL\n }\n }\n return(cov)\n }\n\n # Update or adjust the covariance matrices\n adjust_cov_matrices <- function(cov, samples) {\n for (d in names(cov)) {\n if (d %in% samples) {\n cov[[d]] <- matrix(0, length(samples), length(samples))\n cov[[d]][which(samples == d), which(samples == d)] <- 1\n } else if (d == \"identity\") {\n cov[[d]] <- matrix(0, length(samples), length(samples))\n cov[[d]][1, 1] <- 1 \n } else if (is.null(colnames(cov[[d]]))) {\n cov[[d]] <- cov[[d]][1:length(samples), 1:length(samples)]\n } else {\n cov[[d]] <- cov[[d]][samples, samples]\n }\n cov[[d]] <- as.matrix(cov[[d]])\n }\n return(cov)\n }\n\n # Main function to update the covariance in the MASH model\n update_mash_model_cov <- function(mash_model, all_samples, samples) {\n cov <- mash_model$fitted_g$Ulist\n # Remove matrices that are not required\n cov <- remove_unnecessary_cov_matrices(cov, all_samples, samples)\n \n # Update or reshape the covariance matrices\n cov <- adjust_cov_matrices(cov, samples)\n \n # Update the covariance matrices in the model\n mash_model$fitted_g$Ulist <- cov\n \n # Update the 'pi' attribute of the model\n unwanted_samples <- setdiff(all.samples, samples)\n for (s in unwanted_samples) {\n mash_model$fitted_g$pi <- mash_model$fitted_g$pi[-grep(s, names(mash_model$fitted_g$pi))]\n }\n\n return(mash_model)\n }\n \n outlist = data.frame()\n for (f in c(${_input:r,})) try({\n\n data = readRDS(f)${('$' + data_table_name) if data_table_name else ''}\n data <- handle_nan_etc(data)\n\n if(c(${\",\".join(exclude_condition)})[1] > 0 ){\n message(paste(\"Excluding condition ${exclude_condition} from the analysis\"))\n data$bhat = data$bhat[,-c(${\",\".join(exclude_condition)})]\n data$sbhat = data$sbhat[,-c(${\",\".join(exclude_condition)})]\n data$Z = data$Z[,-c(${\",\".join(exclude_condition)})]\n }\n\n vhat = readRDS(\"${vhat_data if len(posterior_vhat_files) == 0 else posterior_vhat_files[_index]}\")\n mash_model <- readRDS(\"${mash_model}\")\n \n slice_method <- ${'TRUE' if slice_method else 'FALSE'}\n if(slice_method){\n # All additional operations from the second script go here\n\n all.samples <- colnames(data$bhat)\n all.snps <- rownames(data$bhat) \n\n #remove the rows and cols containing NA\n na.test <- data$bhat %>% as.data.frame %>% select_if(~any(!is.na(.))) %>% na.omit %>% as.matrix\n\n #recording meaningful rows and cols\n samples <- colnames(na.test)\n snps <- rownames(na.test)\n\n if(length(all.snps)!=length(snps) | length(all.samples)!=length(samples)){\n # slice data matrix\n data <- slice_and_update_data(data, vhat, snps, samples)\n\n if(length(all.samples)!=length(samples)){\n ##slice the prior\n mash_model <- update_mash_model_cov(mash_model, all_samples, samples)\n }\n }\n }\n\n mash_data = mash_set_data(data$${bhat_table_name}, Shat=data$${shat_table_name}, alpha=${1 if effect_model == 'EZ' else 0}, V=vhat, zero_Bhat_Shat_reset = 1E3)\n mash_output = mash_compute_posterior_matrices(mash_model, mash_data, output_posterior_cov=TRUE)\n mash_output$snps = data$snps\n samplename <- str_split(f, \"/\", simplify = T) %>% .[length(.)] %>% gsub('.rds', '', .)\n saveRDS(mash_output, paste0(\"${_output:d}\", \"/\", samplename, \".posterior.rds\"))\n outlist <- rbind(outlist, paste0(\"${_output:d}\", \"/\", samplename, \".posterior.rds\"))\n\n })\n write.table(outlist, ${_output:r}, col.names=F, row.names=F, quote=F)\n" + "source": [ + "# Compute MASH posteriors per analysis unit (one posterior RDS per region)\n", + "[posterior_1]\n", + "# File listing per-region data RDS paths (col 1); each carries bhat/sbhat matrices\n", + "parameter: analysis_units = path\n", + "# Effect-size / standard-error list elements inside each region RDS\n", + "parameter: bhat_table_name = 'bhat'\n", + "parameter: shat_table_name = 'sbhat'\n", + "# Conditions (columns) to exclude; names or 1-based indices\n", + "parameter: exclude_condition = []\n", + "posterior_input = [line.split()[0] for line in open(analysis_units).readlines() if line.strip() and not line.strip().startswith('#')]\n", + "input: posterior_input, group_by = 1\n", + "output: f\"{cwd}/cache/{name}.{_input:bn}.posterior.rds\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_posterior.R \\\n", + " --data ${_input} \\\n", + " --bhat-key ${bhat_table_name} \\\n", + " --shat-key ${shat_table_name} \\\n", + " --vhat-data ${vhat_data} \\\n", + " --mash-model ${mash_model} \\\n", + " --effect-model ${effect_model} \\\n", + " --exclude-condition \"${','.join([str(x) for x in exclude_condition])}\" \\\n", + " --output ${_output}" + ] }, { "cell_type": "code", @@ -292,7 +348,14 @@ "kernel": "SoS" }, "outputs": [], - "source": "[posterior_2]\ninput: group_by = \"all\"\noutput:f\"{cwd}/mash_output_list_{output_suffix}\"\nbash: expand ='${ }', workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\"\n cd ${_input[0]:d}\n cat mash_output_list_*[0-9] >> posterior_file_list\n awk -F 'cis_long_table.' '{print $2}' posterior_file_list| awk -F '.posterior.rds' '{print $1}'|paste - posterior_file_list > ${_output:r}\n rm posterior_file_list\n" + "source": [ + "# Collect the per-region posterior paths into a single list\n", + "[posterior_2]\n", + "input: group_by = \"all\"\n", + "output: f\"{cwd}/{name}.{output_suffix}.posterior_list\"\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " for f in ${_input}; do echo \"$f\"; done > ${_output}" + ] }, { "cell_type": "markdown", @@ -314,7 +377,31 @@ "kernel": "SoS" }, "outputs": [], - "source": "# perform mash posterior contrast for sliced data\n[mash_posterior_contrast_1]\nparameter: grouping_recipe = \"\"\nparameter: posterior_file = path\nparameter: sum_file = path\n\n# Extract data from posterior_file\npaths_posterior = [x.replace(\"\\\"\",\"\").strip().split()[1] for x in open(posterior_file).readlines() if x.strip() and not x.strip().startswith('#')]\n# Create a dictionary from sum_file for quick lookup\ndict_sum = dict([(x.replace(\"\\\"\",\"\").strip().split()[0], x.replace(\"\\\"\",\"\").strip().split()[1]) for x in open(sum_file).readlines() if x.strip() and not x.strip().startswith('#')])\n# Use genes from posterior_file to fetch corresponding paths from sum_file\npaths_sum = [dict_sum[x.replace(\"\\\"\",\"\").strip().split()[0]] for x in open(posterior_file).readlines() if x.strip() and not x.strip().startswith('#')]\n\ninput: paths_posterior, paired_with='paths_sum', group_by=1\noutput: f\"{cwd}/{_input:bnn}_posterior_contrast.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \nR: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n # Load necessary libraries\n library(mashr)\n library(RhpcBLASctl)\n library(magrittr)\n library(tidyverse)\n #library(ttt)\n\n # Set number of threads for BLAS operations\n blas_set_num_threads(1)\n\n # Create a function for pairwise contrast columns\n MakePairwiseContrastCols <- function(contrast_left, orig_vector) {\n orig_vector[contrast_left[1]] <- 1\n orig_vector[contrast_left[2]] <- -1\n orig_vector\n }\n\n # Function to fit contrast data\n FitContrast <- function(index, orig_mean, posterior_mean, posterior_vcov) {\n population_names <- colnames(posterior_mean) %>% str_remove_all(\"BETA_\")\n\n orig_mean_vector <- orig_mean[index,]\n names(orig_mean_vector) <- population_names\n orig_mean_nonzero <- as.vector(orig_mean_vector != 0)\n orig_mean_tested <- names(orig_mean_vector[orig_mean_nonzero])\n \n if(length(orig_mean_tested)>0){\n n_populations <- length(orig_mean_tested)\n\n pairwise_vector <- rep(0, n_populations)\n names(pairwise_vector) <- orig_mean_tested\n\n grouping <- grouping_all[orig_mean_tested]\n if (n_populations > 1) {\n if (n_populations > 2) {\n #####1. deviation contrast\n deviation_contrasts <- rep(-1, n_populations^2) %>% matrix(nrow = n_populations, ncol = n_populations)\n diag(deviation_contrasts) <- n_populations - 1\n rownames(deviation_contrasts) <- orig_mean_tested\n colnames(deviation_contrasts) <- orig_mean_tested\n deviation_contrasts_tested <- deviation_contrasts[, orig_mean_tested]\n\n unique_groups <- unique(grouping)\n for (grp in unique_groups[unique_groups > 0]) {\n #same celltype (e.g. MIC) with different populations would get 1/n for their weight,\n diag(deviation_contrasts_tested)[grouping == grp] <- (n_populations - 1) / length(grouping[grouping == grp])\n deviation_contrasts_tested[grouping == grp, grouping == grp] <- (n_populations - 1) / length(grouping[grouping == grp])\n }\n\n colnames(deviation_contrasts_tested) %<>% str_c(\"_deviation\")\n\n ####2. pairwise contrast\n two_combn <- combn(orig_mean_tested, m = 2)\n pairwise_names <- apply(two_combn, 2, str_c, collapse = \"_vs_\")\n pairwise_contrast <- apply(two_combn, 2, MakePairwiseContrastCols, pairwise_vector)\n\n colnames(pairwise_contrast) <- pairwise_names\n\n # Create a new matrix to store the adjusted values\n pairwise_contrast_new <- pairwise_contrast\n\n # Loop through each column to archieve such goal: e.g.\n # microglia populations would get 1/n_Mic for their weight,\n # and Mic vs Mic would still be 1 vs -1 to estimate the internal difference among microglia datasets\n for (col in colnames(pairwise_contrast)) {\n # Split column names to get group names\n groups <- strsplit(col, \"_vs_\")[[1]]\n\n # Get the grouping values for the two groups\n group_values <- grouping[names(grouping) %in% groups]\n\n # Identify groups with non-zero grouping values\n relevant_groups <- names(group_values[group_values > 0])\n\n # Check if there are multiple distinct groups\n if (length(unique(group_values)) > 1 && length(relevant_groups) > 0) {\n distinct_groups <- unique(group_values[group_values > 0])\n\n for (distinct_grp in distinct_groups) {\n # Identify rows belonging to the current group\n rows_in_group <- names(grouping[grouping == distinct_grp])\n\n # Adjust the pairwise_contrast values for each row in the group\n pairwise_contrast_new[rows_in_group, col] <- pairwise_contrast[rows_in_group[rows_in_group %in% groups], col] / length(rows_in_group)\n }\n }\n }\n\n # Replace the original matrix with the new one\n pairwise_contrast <- pairwise_contrast_new\n\n #### 3. combine them\n contrast_design <- cbind(deviation_contrasts_tested / (n_populations - 1), pairwise_contrast)\n\n } else {\n pairwise_vector[orig_mean_tested[1]] <- 1\n pairwise_vector[orig_mean_tested[2]] <- -1\n contrast_design <- as.matrix(pairwise_vector)\n colnames(contrast_design) <- str_c(orig_mean_tested[1], \"_vs_\", orig_mean_tested[2])\n }\n\n posterior_mean_subset <- posterior_mean[index,]\n posterior_mean_subset2 <- posterior_mean_subset[orig_mean_tested]\n posterior_vcov_subset <- posterior_vcov[,,index]\n posterior_vcov_subset2 <- posterior_vcov_subset[orig_mean_tested,orig_mean_tested]\n\n contrast_diff <- t(contrast_design) %*% posterior_mean_subset2\n contrast_vcov <- t(contrast_design) %*% posterior_vcov_subset2 %*% contrast_design\n contrast_se <- diag(contrast_vcov) %>% sqrt\n\n contrast_p <- 2 * (1 - pnorm(abs(contrast_diff) / contrast_se))\n\n contrast_diff_df <- t(contrast_diff) %>% as_tibble\n colnames(contrast_diff_df) %<>% str_c(\"mean_contrast_\", .)\n contrast_se_df <- t(contrast_se) %>% as_tibble\n colnames(contrast_se_df) %<>% str_c(\"se_contrast_\", .)\n contrast_p_df <- t(contrast_p) %>% as_tibble\n colnames(contrast_p_df) %<>% str_c(\"p_contrast_\", .)\n\n contrast_df <- bind_cols(contrast_diff_df, contrast_se_df, contrast_p_df)\n } else if(grouping[orig_mean_tested][1]!=grouping[orig_mean_tested][2]){\n contrast_vector <- rep(NA, length(population_names))\n names(contrast_vector) <- str_c(\"mean_contrast_\", population_names, \"_deviation\")\n contrast_df <- t(contrast_vector) %>% as_tibble\n }\n \n contrast_df <- contrast_df %>% as.data.frame\n rownames(contrast_df) <- rownames(posterior_mean)[index]\n return(contrast_df)\n }\n \n }\n\n if(length(\"${cells}\") > 0){\n # All the cells\n cells <- c(\"${\", \".join(cells)}\") %>% str_split(., \",\", simplify = TRUE) %>% as.character \n\n # Automatically set grouping categories based on the recipe\uff0c set0 for the celltypes without multiple populations\n grouping_all <- rep(0, length(cells))\n names(grouping_all) <- cells\n \n \n # Read groupings from the recipe\n if(length(\"${group1}\") > 0){\n cell_groups <- list(\n ${\"group1 = c(\" + \", \".join([\"'\" + item + \"'\" for item in group1]) + \")\" if len(group1) > 0 else \"\"} \n ${\", group2 = c(\" + \", \".join([\"'\" + item + \"'\" for item in group2]) + \")\" if len(group2) > 0 else \"\"} \n ${\", group3 = c(\" + \", \".join([\"'\" + item + \"'\" for item in group3]) + \")\" if len(group3) > 0 else \"\"}\n )\n if(!is.null(cell_groups)) {\n cell_groups <- map(cell_groups, ~str_split(.x, \",\", simplify = TRUE) %>% as.character())\n }\n }\n \n if(\"${grouping_recipe}\" != \"\"){\n cell_groups <- readLines(\"${grouping_recipe}\")\n cell_groups <- lapply(cell_groups, function(g) strsplit(g, \",\")[[1]])\n }\n\n if(!is.null(cell_groups)){\n for(i in seq_along(cell_groups)) {\n grouping_all[cell_groups[[i]]] <- i\n }\n }\n }\n\n \n # Read the data files\n orig_data <- read_rds(\"${_paths_sum[0]}\")$bhat\n posterior_data <- read_rds(\"${_input}\")\n posterior_mean <- posterior_data$PosteriorMean\n posterior_cov <- posterior_data$PosteriorCov\n\n # Align data and clean-up NaN values\n orig_data <- orig_data[, colnames(posterior_mean), drop = FALSE]\n orig_data[which(is.nan(orig_data))] <- 0 # Placeholder for NaNs\n\n # Apply the FitContrast function and consolidate results\n contrast_result <- map(1:nrow(posterior_mean), FitContrast, orig_data, posterior_mean, posterior_cov) %>% bind_rows %>%\n select(matches(\"mean_contrast.*deviation\"), matches(\"mean_contrast.*_vs_\"), \n matches(\"se_contrast.*deviation\"), matches(\"se_contrast.*_vs_\"), \n matches(\"p_contrast.*deviation\"), matches(\"p_contrast.*_vs_\"))\n #rownames(contrast_result) <- rownames(posterior_mean)\n\n write_rds(contrast_result, ${_output:r})" + "source": [ + "# Per-region posterior contrasts (deviation + pairwise) via mashPosteriorContrast\n", + "[mash_posterior_contrast_1]\n", + "# File listing per-region data RDS paths (same units as posterior_1)\n", + "parameter: analysis_units = path\n", + "# Effect-size list element inside each region RDS (aligned to the posterior)\n", + "parameter: orig_key = 'bhat'\n", + "# Optional file of comma-separated condition groups (one per line)\n", + "parameter: grouping_recipe = ''\n", + "contrast_units = [line.split()[0] for line in open(analysis_units).readlines() if line.strip() and not line.strip().startswith('#')]\n", + "input: contrast_units, group_by = 1\n", + "output: f\"{cwd}/contrast/{name}.{_input:bn}.posterior_contrast.rds\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_posterior_contrast.R \\\n", + " --posterior ${cwd}/cache/${name}.${_input:bn}.posterior.rds \\\n", + " --orig-data ${_input} \\\n", + " --orig-key ${orig_key} \\\n", + " --cells ${','.join(cells)} \\\n", + " --group1 \"${','.join(group1)}\" \\\n", + " --group2 \"${','.join(group2)}\" \\\n", + " --group3 \"${','.join(group3)}\" \\\n", + " --grouping-recipe \"${grouping_recipe}\" \\\n", + " --output ${_output}" + ] }, { "cell_type": "code", @@ -323,7 +410,18 @@ "kernel": "SoS" }, "outputs": [], - "source": "# merge the contrast data with slice data\n[mash_posterior_contrast_2]\ninput: group_by = \"all\"\noutput: f\"{cwd}/posterior_sum.csv\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = '24h', mem = '10G', tags = f'{_output:bn}' \n\nR: expand = \"${ }\",stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout' \n library(dplyr)\n library(tidyverse)\n library(ggnewscale)\n \n all.list <- stringr::str_split(\"${_input}\", \" \", simplify = T)\n \n p_cut <- ${p_cut} %>% as.numeric\n\n cells<-c(\"${\",\".join(cells)}\")%>%str_split(.,\",\",simplify = T)%>%as.character #ggnewscale cannot use a specified order, I can not find a good way to order them by category for now\n conditions <-combn(cells, m = 2) %>%apply(., 2, str_c, collapse = \"_vs_\") \n \n df <- matrix(ncol = length(conditions), nrow = 4) %>% as.data.frame()\n colnames(df) <- conditions\n rownames(df) <- c( \"n_sig_snp\", \"n_snp\",\"n_sig_feature\",\"n_all_feature\")\n for (con in conditions) {\n n.all.sig.snp <- n.all.snp <- n.all.sig.feature <- n.all.feature <- 0\n\n for (i in 1:length(all.list)) {\n tmp <- readRDS(all.list[i])\n p.mtx <- tmp %>% select(matches(\"p_contrast.*_vs_\"))\n p.mtx.con <- p.mtx %>% select(matches(con))\n # print(n.sig.snp)\n if(ncol(p.mtx.con)>0){\n p.mtx.con<-na.omit(p.mtx.con)\n n.sig.snp <- sum(p.mtx.con < p_cut)\n n.snp <- nrow(p.mtx.con)\n } else {\n n.sig.snp <- n.snp <-0\n }\n # print(n.snp)\n n.sig.feature <- ifelse(n.sig.snp > 0, 1, 0)\n n.feature<- ifelse (n.snp > 0 , 1, 0)\n\n n.all.sig.snp <- n.sig.snp + n.all.sig.snp\n n.all.snp <- n.all.snp + n.snp\n n.all.sig.feature <- n.all.sig.feature + n.sig.feature\n n.all.feature <- n.all.feature + n.feature\n }\n df[, con] <- c( n.all.sig.snp,n.all.snp, n.all.sig.feature,n.all.feature)\n }\n write.csv(df, \"${_output}\")" + "source": [ + "# Summarize contrast significance across regions -> CSV\n", + "[mash_posterior_contrast_2]\n", + "input: group_by = \"all\"\n", + "output: f\"{cwd}/{name}.posterior_sum.csv\"\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_posterior_contrast_summary.R \\\n", + " --contrast ${_input} \\\n", + " --cells ${','.join(cells)} \\\n", + " --p-cutoff ${p_cut} \\\n", + " --output ${_output}" + ] }, { "cell_type": "code", @@ -333,7 +431,16 @@ "tags": [] }, "outputs": [], - "source": "# plot contrast result\n[mash_posterior_contrast_3, posterior_cntrast_plot]\ninput: group_by = \"all\"\noutput: f\"{cwd}/posterior_sum.png\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = '24h', mem = '10G', tags = f'{_output:bn}' \n\nR: expand = \"${ }\",stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout' \n library(dplyr)\n library(tidyverse)\n library(ggnewscale)\n df <- read.csv(\"${_input:a}\",row.names=1)\n colnames(df)<-gsub(\"DLPFC_\",\"\",colnames(df))\n for (i in 1:ncol(df)) {\n con1 <- stringr::str_split(colnames(df)[i], \"_vs_\", simplify = T)[, 1]\n con2 <- stringr::str_split(colnames(df)[i], \"_vs_\", simplify = T)[, 2]\n\n if (con1 > con2) {\n new.name <- paste0(con2, \"_vs_\", con1)\n colnames(df)[i] <- new.name\n }\n }\n\n ## summarizxse with approach 1: snp-feature pair\n snp.ratio <- df[\"n_sig_snp\", ] / df[\"n_snp\", ]\n snp.ratio <- snp.ratio %>%\n t() %>%\n as.data.frame()\n colnames(snp.ratio) <- \"ratio\"\n snp.ratio$group <- \"snp\"\n\n ## summarize with approach 2: feature\n fet.ratio <- df[\"n_sig_feature\", ] / df[\"n_all_feature\", ]\n fet.ratio <- fet.ratio %>%\n t() %>%\n as.data.frame()\n rownames(fet.ratio) <- paste0(stringr::str_split(rownames(fet.ratio), \"_vs_\", simplify = T)[, 2], \"_vs_\", stringr::str_split(rownames(fet.ratio), \"_vs_\", simplify = T)[, 1])\n colnames(fet.ratio) <- \"ratio\"\n fet.ratio$group <- \"feature\"\n ratio <- rbind(snp.ratio, fet.ratio)\n\n ## I need to add the below to make it Simmetrie\n\n cons <- rownames(ratio) %>%\n str_split(., \"_vs_\", simplify = T) %>%\n .[, 1] %>%\n unique()\n for (i in 1:length(cons)) {\n new.name <- paste0(cons[i], \"_vs_\", cons[i])\n ratio[new.name, ] <- 0\n }\n\n ratio$con1 <- stringr::str_split(rownames(ratio), \"_vs_\", simplify = T)[, 1]\n ratio$con2 <- stringr::str_split(rownames(ratio), \"_vs_\", simplify = T)[, 2]\n\n ## prepare for the plot, score1 is for snp-feature pair, score2 is for feature only\n ratio$score1 <- ratio$score2 <- 0\n ratio$score1[ratio$group == \"snp\"] <- ratio$ratio[ratio$group == \"snp\"]\n ratio$score2[ratio$group == \"feature\"] <- ratio$ratio[ratio$group == \"feature\"]\n ratio$label <- paste0(round(ratio$ratio, 4) * 100, \"%\")\n ratio$label[ratio$group == 0] <- NA\n\n # plot\n num_cols <- length(cons)\n height <- width <- 4 + num_cols * 0.5 \n ggplot(ratio[ratio$group == \"snp\", ], aes(x = con1, y = con2)) +\n geom_tile(aes(fill = score1)) +\n scale_fill_gradient2(\"SNP_Feature pair\",\n low = \"#762A83\", mid = \"white\", high = \"#1B7837\"\n ) +\n new_scale(\"fill\") +\n geom_tile(aes(fill = score2), data = subset(ratio, group != \"snp\")) +\n scale_fill_gradient2(\"Feature\",\n low = \"#1B7837\", mid = \"white\", high = \"#762A83\"\n ) +\n geom_text(data = ratio, aes(label = label)) +\n theme_bw()\n #geom_text(data=ratio, aes(label = label, color = factor(group))) +theme_bw()\n #ggsave(gsub(\".csv\",\".png\",filename))\n\n ggsave(\"${_output}\",width = width, height = height)" + "source": [ + "# Plot the contrast significance summary as a symmetric heatmap\n", + "[mash_posterior_contrast_3, posterior_cntrast_plot]\n", + "input: group_by = \"all\"\n", + "output: f\"{cwd}/{name}.posterior_sum.png\"\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_posterior_contrast_plot.R \\\n", + " --data ${_input} \\\n", + " --output ${_output}" + ] }, { "cell_type": "markdown", @@ -353,7 +460,24 @@ "kernel": "SoS" }, "outputs": [], - "source": "# compute feature score from contrast results\n[feature_score_meta_1]\n#regions = [x.replace(\"\\\"\",\"\").strip().split() for x in open(analysis_unit).readlines() if x.strip() and not x.strip().startswith('#')]\nparameter: plink_path = ''\nparameter: bfile_path = ''\nparameter: extract = ''\nparameter: window_size = '100'\nparameter: step_size = '10'\nparameter: r2_threshold = '0.2'\nparameter: per_chunk = '100'\nparameter: LD_prune = \"TRUE\"\nparameter: downsample_ratio = '1'\nparameter: meta_method = 'REML'\nparameter: LDcache = ''\nparameter: contrast_input = [path(x[0]) for x in regions]\ninput: contrast_input, group_by = per_chunk\noutput: f\"{cwd}/feature_score_metaLD/cache/mash_posterior_contrast_featurescore{_index+1}.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \nR: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n # Library Loading\n suppressMessages({\n library(data.table)\n library(tidyverse)\n library(metafor)\n })\n\n # Environment Configuration\n plink_path <- \"${plink_path}\"\n bfile_path <- \"${bfile_path}\"\n indep_pairwise <- paste(\"${window_size}\", \"${step_size}\", \"${r2_threshold}\")\n out <- NULL\n set.seed(999)\n\n # Define helper functions\n\n plink_ld_pruning <- function(res, chr, bfile_path, LDcache, gene, plink_path, indep_pairwise) {\n extract <- str_c(\"${LDcache}\", gene, \"_snp.list\")\n output <- str_c(\"${LDcache}\", gene, \"_output\")\n tmp_contrast_results <- readRDS(res) %>% as.matrix()\n write.table(rownames(tmp_contrast_results), extract, quote = F)\n # system(paste0(\"rm \", output, \"*\"), intern = TRUE)\n bfile <- str_c(bfile_path, chr)\n command <- paste(plink_path, \"--bfile\", bfile, \"--extract\", extract, \"--indep-pairwise\", indep_pairwise, \"--out\", output)\n system(command, intern = TRUE)\n ld_output <- read.table(str_c(\"${LDcache}\", gene, \"_output.prune.in\"))\n return(tmp_contrast_results[ld_output$V1, ] %>% as.data.table())\n }\n\n calculate_feature_scores <- function(tmp_contrast_results, meta_method) {\n effect_sizes <- tmp_contrast_results %>% select(matches(\"mean_contrast.*deviation\")) %>% as.matrix()\n se_values <- tmp_contrast_results %>% select(matches(\"se_contrast.*deviation\")) %>% as.matrix()\n feature_scores <- data.table()\n for (i in 1:ncol(effect_sizes)) {\n effect_sizes_condition <- effect_sizes[, i]\n se_values_condition <- se_values[, i]\n absolute_effect_sizes <- abs(as.numeric(effect_sizes_condition))\n pairwise_standard_errors <- as.numeric(se_values_condition)\n meta_result <- rma(yi = absolute_effect_sizes, sei = pairwise_standard_errors, method = meta_method)\n z_scores <- meta_result$b / meta_result$se\n feature_scores_condition <- data.table(ZScore = z_scores)\n feature_scores <- rbindlist(list(feature_scores, feature_scores_condition))\n }\n return(feature_scores)\n }\n\n # Main Loop\n for (res in c(${_input:r,})) try({\n chr <- res %>% basename() %>% str_extract(., paste0(\"\\\\.(.*?)\\\\.\")) %>% str_replace_all(\"\\\\.\", \"\") %>% str_replace_all(\"chr\", \"\")\n gene <- basename(res) %>% stringr::str_split(., \"norminal.cis_long_table.\", simplify = TRUE) %>% .[, 2] %>% gsub(\"_posterior_contrast.rds\", \"\", .)\n\n tmp_contrast_results <- readRDS(res)\n\n LD_prune <- ${'TRUE' if LD_prune else 'FALSE'}\n if (LD_prune) {\n tmp_contrast_results <- plink_ld_pruning(res, chr, bfile_path, LDcache, gene, plink_path, indep_pairwise)\n }\n\n if (ncol(tmp_contrast_results %>% select(matches(\"mean_contrast.*deviation\"))) > 0) {\n feature_scores <- calculate_feature_scores(tmp_contrast_results, \"${meta_method}\")\n colnames(feature_scores) <- gene\n condition_name <- colnames(effect_sizes) %>% gsub(\"mean_contrast_\", \"\", .) %>% gsub(\"_deviation\", \"\", .)\n feature_scores <- feature_scores[, condition := condition_name]\n saveRDS(feature_scores, str_c(\"${_output:d}\", \"/\", gsub(\".rds\", \"_featurescore.rds\", basename(res))))\n }\n\n if (is.null(out)) {\n out <- feature_scores\n } else {\n out <- merge(out, feature_scores, by = \"condition\", all = TRUE)\n }\n })\n saveRDS(out, \"${_output}\")\n" + "source": [ + "# Feature score (meta) from per-region contrast results\n", + "[feature_score_meta_1]\n", + "# File listing per-region posterior-contrast RDS paths\n", + "parameter: contrast_units = path\n", + "# Random-effects estimator (metafor via pecotmr)\n", + "parameter: meta_method = 'REML'\n", + "feature_input = [line.split()[0] for line in open(contrast_units).readlines() if line.strip() and not line.strip().startswith('#')]\n", + "input: feature_input, group_by = per_chunk\n", + "output: f\"{cwd}/feature_score_meta/cache/{name}.featurescore{_index+1}.rds\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_feature_score.R \\\n", + " --method meta \\\n", + " --contrast ${_input} \\\n", + " --meta-method ${meta_method} \\\n", + " --output ${_output}" + ] }, { "cell_type": "markdown", @@ -374,7 +498,26 @@ "kernel": "SoS" }, "outputs": [], - "source": "# compute feature score from contrast results with eQTL and pQTL finemapped signals\n[feature_score_finemap_1]\n#regions = [x.replace(\"\\\"\",\"\").strip().split() for x in open(analysis_unit).readlines() if x.strip() and not x.strip().startswith('#')]\nparameter: per_chunk = '100'\nparameter: pfine_path = ''\nparameter: efine_path = ''\nparameter: efine_suffix = \".unisusie.fit.variant.tsv\"\nparameter: gene_ref_path = ''\nparameter: contrast_input = [path(x[0]) for x in regions]\ninput: contrast_input, group_by = per_chunk\noutput: f\"{cwd}/feature_score_finemap/cache/mash_posterior_contrast_featurescore{_index+1}.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \nR: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n # Load necessary libraries\n suppressMessages({\n library(data.table)\n library(tidyverse)\n })\n\n # Function to calculate scores from fine-mapping results\n score_from_cs <- function(fine.file, contrast_results, con) {\n CSs <- unique(fine.file$cs_order) %>% .[. != 0]\n max.cs.df <- NULL\n for (cs in CSs) {\n tmp <- fine.file[fine.file$cs_order == cs, ]\n max.cs.df <- rbind(max.cs.df, tmp[tmp$pip == max(tmp$pip), ])\n }\n snps <- intersect(rownames(contrast_results), max.cs.df$variants)\n if (length(snps) == 0) return(NA)\n\n # Extract contrast p-values\n contrast_p <- NULL\n if (ncol(select(contrast_results %>% as.data.frame(), matches(str_c(\"p_contrast_\", con, \"_deviation\")))) > 0) {\n contrast_p <- contrast_results[snps, str_c(\"p_contrast_\", con, \"_deviation\"), drop = F]\n } else if (ncol(select(contrast_results %>% as.data.frame(), matches(\"p_contrast.*_vs_*\"))) == 1) {\n contrast_p <- contrast_results %>% as.data.frame() %>% select(matches(\"p_contrast.*_vs_*\")) %>% .[snps, , drop = F]\n }\n\n if (is.null(contrast_p)) return(NA)\n\n max.snp <- contrast_p[contrast_p[, 1] == max(contrast_p[, 1]), , drop = F] %>% rownames()\n score <- max(abs(contrast_results %>% as.data.frame() %>% select(matches(\"mean_contrast.*_vs_*\")) %>% .[max.snp, ]) /\n (contrast_results %>% as.data.frame() %>% select(matches(\"se_contrast.*_vs_*\")) %>% .[max.snp, ]))\n return(score)\n }\n\n # Read pQTL file\n pfine.mapped.result <- fread(\"${pfine_path}\")\n pfine.mapped.result$Gene <- str_split(pfine.mapped.result$molecular_trait_id, \"_\", simplify = TRUE)[, 2]\n gene.ref <- read.table(\"${gene_ref_path}\")\n out <- data.table()\n\n # Loop through each input and compute scores\n for (res in c(${_input:r,})) {\n tmp_contrast_results <- readRDS(res) %>% as.matrix()\n\n gene <- basename(res) %>%\n str_split(., \"norminal.cis_long_table.\", simplify = TRUE) %>%\n .[, 2] %>%\n gsub(\"_posterior_contrast.rds\", \"\", .)\n ensemble <- gene.ref[gene.ref$V5 == gene, ]$V4\n efine.mapped.result <- list.files(path = \"${efine_path}\", pattern = paste0(ensemble, \"${efine_suffix}\"), full.names = T)\n pfine.file <- pfine.mapped.result[pfine.mapped.result$Gene == gene & pfine.mapped.result$cs_order > 0, ]\n\n df <- data.frame()\n if (nrow(pfine.file) > 0) {\n message(\"Extracting signal from pQTL in \", gene)\n df[gene, \"DLPFC_pQTL\"] <- score_from_cs(pfine.file, tmp_contrast_results, \"DLPFC_pQTL\")\n }\n if (length(efine.mapped.result) > 0) {\n fine.conditions <- basename(efine.mapped.result) %>%\n sub(\"demo.\", \"\", .) %>%\n sub(paste0(\".\", ensemble, \"${efine_suffix}\"), \"\", .) %>%\n .[. != \"ALL\"] %>%\n .[. != \"End\"]\n for (con in fine.conditions) {\n con.file <- efine.mapped.result[grep(con, efine.mapped.result)] %>% fread()\n con.fine.file <- con.file[con.file$cs_order > 0, ]\n if (nrow(con.fine.file) > 0) {\n df[gene, con] <- score_from_cs(con.fine.file, tmp_contrast_results, con)\n }\n }\n }\n saveRDS(df, str_c(\"${cwd}\",\"/feature_score_finemap/cache/\",gsub(\".rds\",\"_featurescore.rds\",basename(res))))\n out <- rbindlist(list(out, as.data.table(df, keep.rownames = TRUE)), use.names = TRUE, fill = TRUE)\n }\n saveRDS(out, \"${_output}\")\n" + "source": [ + "# Feature score (finemap) using credible sets from fine-mapping\n", + "[feature_score_finemap_1]\n", + "parameter: contrast_units = path\n", + "# Fine-mapping table RDS with cs_order / pip / variants columns\n", + "parameter: fine_mapping = path\n", + "# Conditions to score (default: all contexts present in the contrast)\n", + "parameter: conditions = ''\n", + "feature_input = [line.split()[0] for line in open(contrast_units).readlines() if line.strip() and not line.strip().startswith('#')]\n", + "input: feature_input, group_by = per_chunk\n", + "output: f\"{cwd}/feature_score_finemap/cache/{name}.featurescore{_index+1}.rds\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_feature_score.R \\\n", + " --method finemap \\\n", + " --contrast ${_input} \\\n", + " --fine-mapping ${fine_mapping} \\\n", + " --conditions \"${conditions}\" \\\n", + " --output ${_output}" + ] }, { "cell_type": "code", @@ -383,7 +526,16 @@ "kernel": "SoS" }, "outputs": [], - "source": "# merge the feature score from contrast results with eQTL and pQTL finemapped signals\n[feature_score_finemap_2]\ninput: group_by = \"all\"\noutput: f\"{cwd}/feature_score_finemap/posterior_feature_score_sum.csv\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = '24h', mem = '10G', tags = f'{_output:bn}' \n\nR: expand = \"${ }\",stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout' \n suppressMessages(library(data.table))\n suppressMessages(library(tidyverse))\n \n out <- data.table()\n\n all.list <- stringr::str_split(\"${_input}\", \" \", simplify = T)\n for (i in all.list) {\n feature_scores <- readRDS(i)\n # Print the feature scores for each condition\n if (!is.null(feature_scores)) {\n if (is.null(out)) {\n out <- as.data.table(feature_scores, keep.rownames = TRUE)\n } else {\n out <- rbindlist(list(out, as.data.table(feature_scores, keep.rownames = TRUE)), use.names = TRUE, fill = TRUE)\n }\n }\n }\n write.csv(out, \"${_output}\")" + "source": [ + "# Merge per-chunk finemap feature scores into one table\n", + "[feature_score_finemap_2]\n", + "input: group_by = \"all\"\n", + "output: f\"{cwd}/{name}.{step_name}.feature_score_sum.csv\"\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_feature_score_merge.R \\\n", + " --scores ${_input} \\\n", + " --output ${_output}" + ] }, { "cell_type": "markdown", @@ -402,7 +554,24 @@ "kernel": "SoS" }, "outputs": [], - "source": "# compute feature score from contrast results\n[feature_score_nsig_1]\n#regions = [x.replace(\"\\\"\",\"\").strip().split() for x in open(analysis_unit).readlines() if x.strip() and not x.strip().startswith('#')]\nparameter: per_chunk = '100'\nparameter: contrast_input = [path(x[0]) for x in regions]\ninput: contrast_input, group_by = per_chunk\noutput: f\"{cwd}/feature_score_nsig/cache/mash_posterior_contrast_featurescore_nsig{_index+1}.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \nR: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n # Load required libraries\n suppressMessages({\n library(data.table)\n library(tidyverse)\n library(metafor)\n })\n\n # Convert p_cut to numeric\n p_cut <- ${p_cut} %>% as.numeric\n\n # Initialize the output data table\n out <- NULL\n set.seed(999)\n\n # Function to extract the gene name from the file path\n get_gene_name <- function(file_path) {\n basename(file_path) %>%\n stringr::str_split(., \"norminal.cis_long_table.\", simplify = TRUE) %>%\n .[, 2] %>%\n gsub(\"_posterior_contrast.rds\", \"\", .)\n }\n\n # Loop through each input RDS file\n for (res in c(${_input:r,})) {\n try({\n # Extract gene name\n gene <- get_gene_name(res)\n print(gene)\n\n # Load the contrast results and filter columns of interest\n tmp_contrast_results <- readRDS(res) %>%\n select(matches(\"p_contrast_.*deviation\")) %>%\n as.matrix()\n\n # Initialize the feature output data table\n feature.out <- data.table()\n\n # Calculate the ratio for each condition\n for (i in 1:ncol(tmp_contrast_results)) {\n condition_name <- colnames(tmp_contrast_results)[i] %>%\n gsub(\"p_contrast_\", \"\", .) %>%\n gsub(\"_deviation\", \"\", .)\n\n n_sig_snp <- sum(tmp_contrast_results[, i] < p_cut, na.rm = TRUE)\n n_snp <- sum(!is.na(tmp_contrast_results[, i]))\n\n ratio <- n_sig_snp / n_snp\n feature.out <- rbind(feature.out, data.table(gene = gene, condition = condition_name, ratio = ratio))\n }\n\n # Save individual gene results\n saveRDS(feature.out, paste0(\"${_output:d}\", \"/\", gsub(\".rds\", \"_n_sig_ratio.rds\", basename(res))))\n\n # Merge with the overall output\n if (is.null(out)) {\n out <- feature.out\n } else {\n out <- merge(out, feature.out, by = \"condition\", all = TRUE)\n }\n }, silent = TRUE) # Error handling to proceed even if one iteration fails\n }\n\n # Save the combined output\n saveRDS(out, \"${_output}\")\n" + "source": [ + "# Feature score (nsig) from per-region contrast results\n", + "[feature_score_nsig_1]\n", + "# File listing per-region posterior-contrast RDS paths\n", + "parameter: contrast_units = path\n", + "# Significance cutoff for the n-significant ratio\n", + "parameter: p_cutoff = 0.00001\n", + "feature_input = [line.split()[0] for line in open(contrast_units).readlines() if line.strip() and not line.strip().startswith('#')]\n", + "input: feature_input, group_by = per_chunk\n", + "output: f\"{cwd}/feature_score_nsig/cache/{name}.featurescore{_index+1}.rds\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_feature_score.R \\\n", + " --method nsig \\\n", + " --contrast ${_input} \\\n", + " --p-cutoff ${p_cutoff} \\\n", + " --output ${_output}" + ] }, { "cell_type": "markdown", @@ -415,7 +584,7 @@ "\n", "perform meta analysis with pairwise contrasts to get a pvalue to find to understand what the specific differences are.\n", "\n", - "metaanalysis return a warning as \"Warning message: \u201cRatio of largest to smallest sampling variance extremely large. May not be able to obtain stable results.\u201d\"\n", + "metaanalysis return a warning as \"Warning message: “Ratio of largest to smallest sampling variance extremely large. May not be able to obtain stable results.”\"\n", "Which is due to the big difference between max(pairwise_standard_errors^2) and min(pairwise_standard_errors^2) So I have delete the snps with small pairwise_standard_errors as Xuewei suggested" ] }, @@ -433,7 +602,26 @@ "kernel": "SoS" }, "outputs": [], - "source": "# compute feature score from contrast results\n[feature_pval_pair_1]\n#regions = [x.replace(\"\\\"\",\"\").strip().split() for x in open(analysis_unit).readlines() if x.strip() and not x.strip().startswith('#')]\nparameter: plink_path = ''\nparameter: bfile_path = ''\nparameter: extract = ''\nparameter: window_size = '100'\nparameter: step_size = '10'\nparameter: r2_threshold = '0.2'\nparameter: per_chunk = '100'\nparameter: LD_prune = True\nparameter: downsample_ratio = '1'\nparameter: meta_method = 'REML'\nparameter: se_cutoff = '1E-03'\nparameter: LDcache = ''\nparameter: contrast_input = [path(x[0]) for x in regions]\ninput: contrast_input, group_by = per_chunk\noutput: f\"{cwd}/feature_pval_pair/cache/mash_posterior_contrast_featurescore{_index+1}.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \nR: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n # Library Loading\n suppressMessages({\n library(data.table)\n library(tidyverse)\n library(metafor)\n })\n\n # Initializations\n out <- NULL\n set.seed(999)\n\n # Helper function: extract gene name from result\n extract_gene <- function(res) {\n basename(res) %>%\n stringr::str_split(., \"norminal.cis_long_table.\", simplify = TRUE) %>%\n .[, 2] %>%\n gsub(\"_posterior_contrast.rds\", \"\", .)\n }\n\n # Helper function: perform meta analysis per cell\n meta_analysis_per_cell <- function(effect_sizes, se_values, gene, se_cutoff) {\n conditions <- colnames(effect_sizes) %>%\n sub(\"mean_contrast_\", \"\", .) %>%\n unique()\n cells <- c(sub(\"_vs_.*\", \"\", conditions), sub(\".*_vs_\", \"\", conditions)) %>% unique()\n\n df <- data.table()\n for (cell in cells) {\n cell.b <- effect_sizes[, grep(cell, colnames(effect_sizes)), drop = F]\n cell.se <- se_values[, grep(cell, colnames(se_values)), drop = F]\n feature_pvals <- data.table()\n for (i in 1:ncol(cell.b)) {\n effect_sizes_condition <- cell.b[, i]\n se_values_condition <- cell.b[, i]\n # Filter out based on se cutoff\n effect_sizes_condition <- effect_sizes_condition[which(se_values_condition > as.numeric(se_cutoff))]\n se_values_condition <- se_values_condition[which(se_values_condition > as.numeric(se_cutoff))]\n # Meta-analysis\n absolute_effect_sizes <- abs(as.numeric(effect_sizes_condition))\n pairwise_standard_errors <- as.numeric(se_values_condition)\n meta_result <- rma(yi = absolute_effect_sizes, sei = pairwise_standard_errors, method = \"REML\")\n feature_pval_condition <- data.table(pavlue = meta_result$pval)\n feature_pvals <- rbindlist(list(feature_pvals, feature_pval_condition))\n }\n colnames(feature_pvals) <- gene\n condition_name <- colnames(cell.b) %>%\n gsub(\"mean_contrast_\", \"\", .)\n feature_pvals <- feature_pvals[, condition := condition_name]\n df <- rbindlist(list(df, feature_pvals))\n }\n return(df)\n }\n\n # Main Loop\n for (res in c(${_input:r,})) {\n gene <- extract_gene(res)\n print(gene)\n tmp_contrast_results <- readRDS(res)\n ld_output <- read.table(str_c(\"${LDcache}\", gene, \"_output.prune.in\"))\n tmp_contrast_results <- tmp_contrast_results[ld_output$V1, ] %>% as.data.table(keep.rownames = T)\n\n effect_sizes <- tmp_contrast_results %>% select(matches(\"mean_contrast.*_vs_*\")) %>% as.matrix()\n se_values <- tmp_contrast_results %>% select(matches(\"se_contrast.*_vs_*\")) %>% as.matrix()\n\n df <- meta_analysis_per_cell(effect_sizes, se_values, gene, \"${se_cutoff}\")\n saveRDS(df, str_c(\"${_output:d}\", \"/\", gsub(\".rds\", \"_featurescore_pw.rds\", basename(res))))\n\n if (is.null(out)) {\n out <- df\n } else {\n out <- merge(out, df, by = \"condition\", all = TRUE, allow.cartesian = TRUE)\n }\n }\n saveRDS(out, \"${_output}\")\n" + "source": [ + "# Feature score (pval_pair) from per-region contrast results\n", + "[feature_pval_pair_1]\n", + "# File listing per-region posterior-contrast RDS paths\n", + "parameter: contrast_units = path\n", + "parameter: meta_method = 'REML'\n", + "# SE floor for the pairwise meta-analysis\n", + "parameter: se_cutoff = 0.001\n", + "feature_input = [line.split()[0] for line in open(contrast_units).readlines() if line.strip() and not line.strip().startswith('#')]\n", + "input: feature_input, group_by = per_chunk\n", + "output: f\"{cwd}/feature_score_pval_pair/cache/{name}.featurescore{_index+1}.rds\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_feature_score.R \\\n", + " --method pval_pair \\\n", + " --contrast ${_input} \\\n", + " --meta-method ${meta_method} \\\n", + " --se-cutoff ${se_cutoff} \\\n", + " --output ${_output}" + ] }, { "cell_type": "code", @@ -442,7 +630,16 @@ "kernel": "SoS" }, "outputs": [], - "source": "# merge the feature score from contrast results\n[feature_pval_pair_2, feature_score_meta_2, feature_score_nsig_2]\ninput: group_by = \"all\"\noutput: f\"{cwd}/feature_pval_pair/posterior_feature_score_sum.csv\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = '24h', mem = '10G', tags = f'{_output:bn}' \n\nR: expand = \"${ }\",stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout' \n library(dplyr)\n library(tidyverse)\n out <- NULL\n\n all.list <- stringr::str_split(\"${_input}\", \" \", simplify = T)\n for (i in all.list) {\n feature_scores <- readRDS(i)\n # Print the feature scores for each condition\n if (!is.null(feature_scores)) {\n if (is.null(out)) {\n out <- feature_scores\n } else {\n out <- merge(out, feature_scores, by = \"condition\", all = TRUE)\n }\n }\n }\n out<-t(out)\n #out<-out[-1,]\n write.csv(out, \"${_output}\",col.names=F)" + "source": [ + "# Merge per-chunk feature scores into one table (meta / nsig / pval_pair)\n", + "[feature_pval_pair_2, feature_score_meta_2, feature_score_nsig_2]\n", + "input: group_by = \"all\"\n", + "output: f\"{cwd}/{name}.{step_name}.feature_score_sum.csv\"\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_feature_score_merge.R \\\n", + " --scores ${_input} \\\n", + " --output ${_output}" + ] } ], "metadata": { @@ -486,4 +683,4 @@ }, "nbformat": 4, "nbformat_minor": 4 -} \ No newline at end of file +} diff --git a/code/SoS/multivariate_genome/MASH/mash_preprocessing.ipynb b/code/SoS/multivariate_genome/MASH/mash_preprocessing.ipynb index 00401748b..5ca4c6a56 100644 --- a/code/SoS/multivariate_genome/MASH/mash_preprocessing.ipynb +++ b/code/SoS/multivariate_genome/MASH/mash_preprocessing.ipynb @@ -28,9 +28,9 @@ "\n", "The workflow produces three z-score matrices used to fit a multivariate prior:\n", "\n", - "- **Strong effects (`Z_s`)** \u2014 extracted from genome-wide cis fine-mapping results. The top locus per condition is taken (credible-set coverage threshold 0.7) and the z-scores are merged into one data frame.\n", - "- **Null effects (`Z_n`)** \u2014 up to `M` candidate SNPs per region satisfying |z| \u2264 2 are overlapped with the independent-SNP list to keep only independent variants; the union is taken.\n", - "- **Random effects (`Z_r`)** \u2014 variants randomly sampled from the supplied independent-variant list.\n", + "- **Strong effects (`Z_s`)** — extracted from genome-wide cis fine-mapping results. The top locus per condition is taken (credible-set coverage threshold 0.7) and the z-scores are merged into one data frame.\n", + "- **Null effects (`Z_n`)** — up to `M` candidate SNPs per region satisfying |z| ≤ 2 are overlapped with the independent-SNP list to keep only independent variants; the union is taken.\n", + "- **Random effects (`Z_r`)** — variants randomly sampled from the supplied independent-variant list.\n", "\n", "These matrices feed Ultimate Deconvolution / MASH to learn patterns of effect sharing across conditions (e.g. cell types or tissues)." ] @@ -43,10 +43,10 @@ "source": [ "## Input\n", "\n", - "1. **Marginal summary statistics files** \u2014 bgzipped summary statistics for chromosomes 1\u201322, generated by tensorQTL cis-analysis and indexed by `tabix`.\n", - "2. **Fine-mapping results file index** \u2014 path to lists of fine-mapped RDS files from fine-mapping output (e.g. `susie_list.tsv`).\n", - "3. **Genome region partition** (optional) \u2014 defines genomic regions per gene as enhanced cis regions from which `Z_n` and `Z_r` are extracted. If the complete list of fine-mapping RDS is already available (#2), this file is not required; otherwise extraction is limited to the regions listed (useful for testing).\n", - "4. **Independent variant list** (optional) \u2014 list of LD-pruned independent SNPs used to keep only independent null/random variants." + "1. **Marginal summary statistics files** — bgzipped summary statistics for chromosomes 1–22, generated by tensorQTL cis-analysis and indexed by `tabix`.\n", + "2. **Fine-mapping results file index** — path to lists of fine-mapped RDS files from fine-mapping output (e.g. `susie_list.tsv`).\n", + "3. **Genome region partition** (optional) — defines genomic regions per gene as enhanced cis regions from which `Z_n` and `Z_r` are extracted. If the complete list of fine-mapping RDS is already available (#2), this file is not required; otherwise extraction is limited to the regions listed (useful for testing).\n", + "4. **Independent variant list** (optional) — list of LD-pruned independent SNPs used to keep only independent null/random variants." ] }, { @@ -221,7 +221,7 @@ " ..$ Exc_Kellis_eQTL : num [1:200] 1.091 0.092 0.333 -0.208 0.433 ...\n", " ..$ Inh_Kellis_eQTL : num [1:200] -0.932 -1.002 0.659 1.344 -0.353 ...\n", " ..$ Ast.10_Kellis_eQTL : num [1:200] 0 0 0 0 0 0 0 0 0 0 ...\n", - " $ ZtZ : num [1:16, 1:16] 2.182 1.09 1.481 0.759 2.405 ...\n", + " $ XtX : num [1:16, 1:16] 2.182 1.09 1.481 0.759 2.405 ...\n", " ..- attr(*, \"dimnames\")=List of 2\n", " .. ..$ : chr [1:16] \"Mic_De_Jager_eQTL\" \"Ast_De_Jager_eQTL\" \"Oli_De_Jager_eQTL\" \"OPC_De_Jager_eQTL\" ...\n", " .. ..$ : chr [1:16] \"Mic_De_Jager_eQTL\" \"Ast_De_Jager_eQTL\" \"Oli_De_Jager_eQTL\" \"OPC_De_Jager_eQTL\" ...\n", @@ -245,14 +245,20 @@ "kernel": "SoS" }, "source": [ - "**Step 1.** `susie_to_mash` \u2014 build the MASH input from fine-mapped SuSiE results. Requires `--name`, `--fine_mapping_meta` (the index of fine-mapped RDS files) and `--independent_variant_list`; credible-set coverage and per-chunk size are tunable." + "**Step 1.** `susie_to_mash` — build the MASH input from fine-mapped SuSiE results. Requires `--name`, `--fine_mapping_meta` (the index of fine-mapped RDS files) and `--independent_variant_list`; credible-set coverage and per-chunk size are tunable." ] }, { "cell_type": "markdown", "metadata": {}, "source": [ - "## Important Note: `susie_to_mash` on Toy Data\n\nThe `susie_to_mash` workflow (Step 1) requires **genome-wide fine-mapping outputs** across many regions and conditions \u2014 it is designed for a full-scale run, not a single chr22 toy region. On this toy dataset the step will not complete successfully due to insufficient overlapping regions in the LD reference.\n\n**For the toy MWE demo:** a pre-generated `protocol_example.mash_input.rds` is already staged in `input/mash_preprocessing/`. You can proceed directly to `mash_fit` and `mash_posterior` using that file without running `susie_to_mash` yourself.\n\nTo run `susie_to_mash` on real data, provide a `--fine-mapping-meta` TSV pointing to genome-wide SuSiE outputs with multiple regions across multiple chromosomes." + "## Note: `susie_to_mash` inputs\n", + "\n", + "`susie_to_mash` consumes one **`FineMappingResult` RDS per region** (the S4 output of `fine_mapping.R`), listed in `--fine_mapping_meta` under `--finemapping_column`. For each region it takes the lead variant (max PIP) of every credible set in each condition as the *strong* set, and samples the *random* / *null* background from the region's full variant universe (`pecotmr::mashInput`).\n", + "\n", + "**Toy MWE.** The legacy per-region SuSiE fixtures can be converted once to a `QtlFineMappingResult` — see `tests/fixtures/mash/build_qtl_fine_mapping_result.R`, which builds `protocol_example.QtlFineMappingResult.rds` from the committed toy fine-mapping tables. Point `--fine_mapping_meta` at that RDS to run the toy demo. The toy signal is weak, so loosen `--sig_p_cutoff` (e.g. `0.1`) or every strong variant is filtered out.\n", + "\n", + "For a genome-wide run, provide a `--fine_mapping_meta` listing every region's `FineMappingResult` RDS." ] }, { @@ -273,12 +279,14 @@ "sos run pipeline/mash_preprocessing.ipynb susie_to_mash \\\n", " --name protocol_example_mash \\\n", " --fine_mapping_meta input/finemapping/protocol_example.fine_mapping_meta.tsv \\\n", - " --independent_variant_list input/ld/protocol_example.ld_pruned_variants.txt.gz \\\n", + " --finemapping_column susie_path \\\n", + " --sig_p_cutoff 0.1 \\\n", " --cwd output/mash_preprocessing\n", "\n", - "# NOTE: On single-context toy data this produces a 2-context mash_input.rds.\n", - "# The pre-generated 16-context input is at:\n", - "# input/mash_preprocessing/protocol_example.mash_input.rds\n" + "# --fine_mapping_meta lists one FineMappingResult RDS per region (fine_mapping.R\n", + "# output) in the --finemapping_column. Strong = each credible set's lead variant\n", + "# per condition; random/null are sampled per region. The production\n", + "# --sig_p_cutoff default is 1E-6; loosen it (e.g. 0.1) on weak-signal toy data." ] }, { @@ -288,7 +296,7 @@ }, "source": [ "\n", - "**Step 2.** `random_null_tensorqtl` \u2014 extract the random and null effects directly from tensorQTL summary statistics. Requires `--name`, `--region_file`, `--independent_variant_list`, and the list of summary-statistics files / traits." + "**Step 2.** `random_null_tensorqtl` — extract the random and null effects directly from tensorQTL summary statistics. Requires `--name`, `--region_file`, `--independent_variant_list`, and the list of summary-statistics files / traits." ] }, { @@ -299,16 +307,15 @@ }, "outputs": [], "source": [ - "# Step B uses TensorQTL summary statistics to extract random/null effects.\n", - "# This step requires multi-trait sumstats; toy data has 1 trait so we\n", - "# document the interface only. Use the pre-generated mash_input.rds instead.\n", + "# random_null_tensorqtl builds a multi-context QtlSumStats per region from the\n", + "# matching tensorqtl files (mash_sumstats_construct.R), then assembles the mash\n", + "# input (mash_preprocessing.R). Requires multi-trait tensorqtl sumstats.\n", "sos run pipeline/mash_preprocessing.ipynb random_null_tensorqtl \\\n", " --name protocol_example_mash \\\n", " --region_file input/finemapping/protocol_example.region \\\n", " --sum_files input/protocol_example.sumstats_list.txt \\\n", " --traits bulk_rnaseq \\\n", - " --independent_variant_list input/ld/protocol_example.ld_pruned_variants.txt.gz \\\n", - " --cwd output/mash_preprocessing\n" + " --cwd output/mash_preprocessing" ] }, { @@ -355,9 +362,18 @@ "# Path to work directory where output locates\n", "parameter: cwd = path(\"./output\")\n", "parameter: seed = 999\n", + "# Random / null background rows sampled per region\n", "parameter: n_random = 10\n", "parameter: n_null = 10\n", + "# Conditions (columns) to drop from every partition\n", "parameter: exclude_condition = []\n", + "# Credible-set coverage for FineMappingResult strong selection (susie_to_mash)\n", + "parameter: coverage = 0.95\n", + "# Strong-partition significance cutoff. Production default 1E-6; loosen (e.g.\n", + "# 0.1) for weak-signal toy data or every strong variant is filtered out.\n", + "parameter: sig_p_cutoff = 1E-6\n", + "# Emit only the z-score matrices (drop the effect-size .b / .s matrices)\n", + "parameter: z_only = False\n", "# Containers that contains the necessary packages\n", "parameter: container = \"\"\n", "# For cluster jobs, number commands to run per job\n", @@ -367,9 +383,7 @@ "# Memory expected\n", "parameter: mem = \"16G\"\n", "# Number of threads\n", - "parameter: numThreads = 1\n", - "# This is in principle required; but in practice it can be optional if we are not exactly stringent about getting independent SNPs\n", - "parameter: independent_variant_list = path" + "parameter: numThreads = 1\n# LD-pruned independent SNP list (optional). When provided, restricts the\n# random/null background to matching variants (allele-aware via matchVariants);\n# strong is unaffected. Default path(\".\") means not provided.\nparameter: independent_variant_list = path(\".\")\n" ] }, { @@ -380,166 +394,39 @@ }, "outputs": [], "source": [ - "# extract data for MASH from summary stats\n", - "[susie_to_mash_1]\n", - "parameter: per_chunk = 100\n", + "# Build the MASH input from per-region FineMappingResult RDS (e.g. fine_mapping.R\n", + "# output). Strong = the lead variant (max PIP) of each credible set per\n", + "# condition; random / null are sampled from each region's full variant universe.\n", + "# mashInput merges across regions, cleans via filterInvalidSummaryStat, and\n", + "# appends the strong XtX cross-product.\n", + "[susie_to_mash]\n", + "# Index of per-region fine-mapping results (one row per region)\n", "parameter: fine_mapping_meta = path\n", - "parameter: coverage = \"cs_coverage_0.7\"\n", - "# first 3 col are chr start end, 4th column is region ID, 5th col are file names, 6 col is all the condition names comma split\n", - "import pandas as pd\n", - "df = pd.read_csv(fine_mapping_meta, sep='\\t', na_filter=False)\n", - "meta_data = [\n", - " \"c(\" + \",\".join(f\"'NA'\" if y == '' else f\"'{y}'\" for y in row) + \")\"\n", - " for index, row in df.iterrows()\n", - "]\n", - "def chunker(seq, size):\n", - " return (seq[pos:pos + size] for pos in range(0, len(seq), size)) \n", - "# Desired group size\n", - "grouped_meta_data = list(chunker(meta_data, per_chunk))\n", - "input: for_each = \"grouped_meta_data\"\n", - "output: f\"{cwd}/{name}_cache/{name}_batch{_index+1}.rds\"\n", - "task: trunk_workers = job_size, walltime = walltime, trunk_size = 1, mem = mem, cores = numThreads, tags = f'{_output:bn}'\n", - "R: expand = \"${ }\"\n", - " # Toy-data-compatible direct construction of mash_input\n", - " # (Bypasses load_multitrait_R_sumstat which requires extract_top_loci not in this pecotmr version)\n", - " # Conceptually equivalent: extract z-scores per condition and build strong/random/null matrices\n", - " library(pecotmr)\n", - " db_dat <- readRDS(\"input/finemapping/protocol_example.sumstats_db.rds\")\n", - " conditions <- names(db_dat)\n", - "\n", - " # Extract z-scores per condition (from v2 sumstats_db structure)\n", - " all_z <- list()\n", - " for (cond in conditions) {\n", - " cond_data <- db_dat[[cond]]\n", - " for (region in names(cond_data)) {\n", - " region_data <- cond_data[[region]]\n", - " all_z[[cond]] <- data.frame(\n", - " variants = region_data$variant_names,\n", - " z = region_data$sumstats$z,\n", - " stringsAsFactors = FALSE\n", - " )\n", - " }\n", - " }\n", - "\n", - " # Merge to common variants across all conditions\n", - " common_variants <- Reduce(intersect, lapply(all_z, function(d) d$variants))\n", - "\n", - " # Build z-score matrix\n", - " z_matrix <- data.frame(variants = common_variants, stringsAsFactors = FALSE)\n", - " for (cond in conditions) {\n", - " idx <- match(common_variants, all_z[[cond]]$variants)\n", - " z_matrix[[cond]] <- all_z[[cond]]$z[idx]\n", - " }\n", - " z_only <- as.matrix(z_matrix[, conditions])\n", - " rownames(z_only) <- z_matrix$variants\n", - "\n", - " # Build mash_input structure expected by susie_to_mash_2:\n", - " # list(region_id = list(strong=list(z=df), random=list(z=df), null=list(z=df)))\n", - " region_id <- paste(names(db_dat[[1]]), collapse=\",\")\n", - " strong_z_df <- as.data.frame(z_only)\n", - " random_z_df <- as.data.frame(z_only) # toy data: use all as random\n", - " null_z_df <- as.data.frame(z_only) # toy data: use all as null\n", - "\n", - " res <- list()\n", - " res[[region_id]] <- list(\n", - " strong = list(z = strong_z_df),\n", - " random = list(z = random_z_df),\n", - " null = list(z = null_z_df)\n", - " )\n", - " cat(sprintf(\"Built mash_input for region %s: %d variants x %d conditions\\n\",\n", - " region_id, nrow(z_only), ncol(z_only)))\n", - " dir.create(dirname(${_output:r}), recursive = TRUE, showWarnings = FALSE); saveRDS(res, ${_output:r}, compress = \"xz\")\n", - " cat(\"Saved:\", ${_output:r}, \"\\n\")" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[susie_to_mash_2]\n", - "input: group_by = \"all\"\n", - "output: f\"{cwd}/{name}.mash_input.rds\" \n", - "task: trunk_workers = job_size, walltime = walltime, trunk_size = 1, mem = mem, cores = numThreads, tags = f'{_output:bn}'\n", - "R: expand = \"${ }\", container = container, stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout'\n", - " library(pecotmr)\n", - " # pecotmr compat: installed build calls stale merge_matrices(); shadow loaders with merge_sumstats_matrices\n", - " local({\n", - " .ns <- asNamespace(\"pecotmr\")\n", - " for (.fn in c(\"load_multitrait_R_sumstat\", \"load_multitrait_tensorqtl_sumstat\")) {\n", - " if (!exists(.fn, envir=.ns, inherits=FALSE)) next\n", - " .f <- get(.fn, envir=.ns)\n", - " .bt <- gsub(\"merge_matrices\", \"merge_sumstats_matrices\", deparse(body(.f)))\n", - " .bt <- gsub(\"^( *)ld_meta_file, id_column = .variants., remove_any_missing\\\\)\", \"\\\\1ld_meta_file = ld_meta_file, id_column = 'variants', remove_any_missing = remove_any_missing)\", .bt)\n", - " body(.f) <- parse(text=paste(.bt, collapse=\"\\n\"))[[1]]; environment(.f) <- .ns\n", - " assign(.fn, .f, envir=globalenv())\n", - " }\n", - " })\n", - " # Function to reformat data\n", - " reformat_data <- function(dat) {\n", - " res <- list()\n", - " \n", - " if (!is.null(dat$strong) && !is.null(dat$strong$z)) {\n", - " res$strong.z <- dat$strong$z\n", - " }\n", - " \n", - " if (!is.null(dat$random) && !is.null(dat$random$z)) {\n", - " res$random.z <- dat$random$z\n", - " }\n", - " \n", - " if (!is.null(dat$null) && !is.null(dat$null$z)) {\n", - " res$null.z <- dat$null$z\n", - " }\n", - " \n", - " return(res)\n", - " }\n", - " # Function to rename rownames of dat\n", - " rename_rownames <- function(dat){\n", - " renamed_data <- lapply(names(dat), function(name) {\n", - " # Retrieve the data frame from the list\n", - " sublist <- dat[[name]]\n", - " \n", - " renamed_sublist <- lapply(sublist, function(df) {\n", - " if(length(df)!=0&&!is.null(df)){\n", - " # Check if nrow of df is zero\n", - " if(nrow(df) > 0) {\n", - " # Only rename rownames if df has more than 0 rows\n", - " rownames(df) <- paste(rownames(df), name, sep = \"_\")\n", - " }\n", - " }\n", - " return(df)\n", - " })\n", - " \n", - " return(renamed_sublist)\n", - " })\n", - " # Set the names of the modified list to match the original list\n", - " names(renamed_data) <- names(dat)\n", - " return(renamed_data)\n", - " }\n", - " batch_combined_data <- list()\n", - " for (batch in c(${_input:r,})){\n", - " res_reformatted <- lapply(readRDS(batch), reformat_data)\n", - " renamed_res_reformatted <- rename_rownames(res_reformatted)\n", - " merged_data <- list()\n", - " for(region in names(renamed_res_reformatted)){\n", - " merged_data <- mergeMashData(merged_data, renamed_res_reformatted[[region]])\n", - " }\n", - " batch_combined_data <- mergeMashData(batch_combined_data,merged_data)\n", - " } \n", - " saveRDS(batch_combined_data, \"${_output:n}.with_na.rds\", compress=\"xz\")\n", - " print(head(batch_combined_data))\n", - " conditions = c(\"strong\", \"random\", \"null\")\n", - " for (cond in conditions){\n", - " batch_combined_data <- filterInvalidSummaryStat(batch_combined_data, z = paste0(cond,\".z\"))\n", - " }\n", - " batch_combined_data$ZtZ = t(as.matrix(batch_combined_data$strong.z)) %*% as.matrix(batch_combined_data$strong.z) / nrow(batch_combined_data$strong.z)\n", - " saveRDS(batch_combined_data, ${_output:r}, compress=\"xz\")\n", - " \n", - "bash: expand = \"${ }\", container = container, stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout'\n", - " rm -rf ${cwd}/${name}_cache/" + "# Column in --fine_mapping_meta holding each region's FineMappingResult RDS path\n", + "parameter: finemapping_column = 'susie_path'\n", + "# Column holding the region id (labels rows across regions)\n", + "parameter: region_column = 'region_id'\n", + "import csv\n", + "with open(fine_mapping_meta) as _f:\n", + " _rows = list(csv.DictReader(_f, delimiter = '\\t'))\n", + "_fmr_paths = [r[finemapping_column] for r in _rows]\n", + "_region_ids = \",\".join(str(r[region_column]) for r in _rows)\n", + "input: _fmr_paths\n", + "output: f\"{cwd}/{name}.mash_input.rds\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_preprocessing.R \\\n", + " --objects ${_input} \\\n", + " --region-ids ${_region_ids} \\\n", + " --coverage ${coverage} \\\n", + " --n-random ${n_random} \\\n", + " --n-null ${n_null} \\\n", + " --exclude-condition \"${','.join(exclude_condition)}\" \\\n", + " --sig-p-cutoff ${sig_p_cutoff} \\\n", + " ${'--z-only' if z_only else ''} \\\n", + " ${('--independent-variant-list ' + str(independent_variant_list)) if independent_variant_list.is_file() else ''} \\\n", + " --seed ${seed} \\\n", + " --output ${_output}" ] }, { @@ -570,60 +457,55 @@ "parameter: sum_files = paths\n", "parameter: region_file = path\n", "parameter: traits = paths\n", - "# Added params (were referenced in R block but undefined): runnable defaults\n", - "parameter: na_remove = True\n", - "parameter: z_only = True\n", - "parameter: expected_ncondition = len(traits)\n", - "\n", "import re\n", - "import pandas as pd\n", - "def find_matching_files_for_region(chr_id):\n", - " chr_number = chr_id[3:] # subset 1 from chr1\n", - " pattern_str = r\"\\.{chr_number}\\.\"\n", - " pattern = re.compile(pattern_str.format(chr_number=chr_number))\n", - " paths = []\n", - " for sum_file in sum_files:\n", - " with open(sum_file, 'r') as af:\n", - " for aline in af:\n", - " if pattern.search(aline):\n", - " paths.append(aline.strip())\n", - " return \",\".join(paths)\n", - "\n", - "updated_regions = []\n", - "with open(region_file, 'r') as regions:\n", - " header = regions.readline().strip()\n", - " updated_regions.append(header + \"\\tpath\\tregion\")\n", + "meta = []\n", + "with open(region_file) as regions:\n", + " regions.readline() # header\n", " for line in regions:\n", " parts = line.strip().split(\"\\t\")\n", - " chr_id, start, end, gene_id = parts\n", - " paths = find_matching_files_for_region(chr_id)\n", - " updated_regions.append(f\"{chr_id}\\t{start}\\t{end}\\t{gene_id}\\t{paths}\\t{chr_id}:{start}-{end}\")\n", - "\n", - "meta_df = pd.DataFrame([line.split(\"\\t\") for line in updated_regions[1:]], columns=updated_regions[0].split(\"\\t\"))\n", - "meta = meta_df[['gene_id', 'path', 'region']].to_dict(orient='records')\n", - "\n", - "input: for_each='meta'\n", - "output: f'{cwd:a}/{name}_cache/{name}.{_meta[\"gene_id\"]}.rds'\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", stderr = f'{_output}.stderr', stdout = f'{_output}.stdout', container = container\n", - " region <- \"${_meta['region']}\"\n", - " phenotype_path <- unlist(strsplit(\"${_meta['path']}\", \",\"))\n", - " dat <- tryCatch(\n", - " {\n", - " # Try to run the function\n", - " pecotmr::load_multitrait_tensorqtl_sumstat(sumstats_paths = phenotype_path, region = region, \n", - " trait_names = c(${traits:r,}), filter_file = NULL, remove_any_missing = TRUE, max_rows_selected = 300, nan_remove = ${\"T\" if na_remove else \"F\"})\n", - " },\n", - " error = function(e) {\n", - " warning(\"Attempt remove chr in region ID to load the data.\")\n", - " # If an error occurs, modify the region and try again\n", - " pecotmr::load_multitrait_tensorqtl_sumstat(sumstats_paths = phenotype_path, region = gsub(\"chr\", \"\", region), \n", - " trait_names = c(${traits:r,}), filter_file = NULL, remove_any_missing = TRUE, max_rows_selected = 300, nan_remove = ${\"T\" if na_remove else \"F\"})\n", - " }\n", - " )\n", - " exclude_condition = c(${\",\".join([repr(x) for x in exclude_condition])})\n", - " dat <- pecotmr::mash_ran_null_sample(dat, ${n_random}, ${n_null}, ${expected_ncondition}, exclude_condition, z_only = ${\"TRUE\" if z_only else \"FALSE\"}, seed=${seed})\n", - " saveRDS(dat, ${_output:r}, compress=\"xz\")" + " chr_id, start, end, gene_id = parts[0], parts[1], parts[2], parts[3]\n", + " pattern = re.compile(r\"\\.%s\\.\" % chr_id[3:])\n", + " matched = []\n", + " for sf in sum_files:\n", + " with open(str(sf)) as af:\n", + " for aline in af:\n", + " if pattern.search(aline):\n", + " matched.append(aline.strip())\n", + " meta.append(dict(gene_id = gene_id, paths = \",\".join(matched),\n", + " region = f\"{chr_id}:{start}-{end}\"))\n", + "input: for_each = 'meta'\n", + "output: f'{cwd:a}/{name}_cache/{name}.{_meta[\"gene_id\"]}.qss.rds'\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_sumstats_construct.R \\\n", + " --tensorqtl-paths ${_meta['paths'].replace(',', ' ')} \\\n", + " --conditions ${','.join([str(t) for t in traits])} \\\n", + " --region ${_meta['region']} \\\n", + " --study ${name} \\\n", + " --output ${_output}" + ] + }, + { + "cell_type": "code", + "metadata": {}, + "execution_count": null, + "outputs": [], + "source": [ + "[random_null_tensorqtl_2]\n", + "input: group_by = 'all'\n", + "output: f\"{cwd}/{name}.mash_input.rds\"\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_preprocessing.R \\\n", + " --objects ${_input} \\\n", + " --n-random ${n_random} \\\n", + " --n-null ${n_null} \\\n", + " --exclude-condition \"${','.join(exclude_condition)}\" \\\n", + " --sig-p-cutoff ${sig_p_cutoff} \\\n", + " ${'--z-only' if z_only else ''} \\\n", + " ${('--independent-variant-list ' + str(independent_variant_list)) if independent_variant_list.is_file() else ''} \\\n", + " --seed ${seed} \\\n", + " --output ${_output}" ] } ], @@ -663,4 +545,4 @@ }, "nbformat": 4, "nbformat_minor": 4 -} \ No newline at end of file +} diff --git a/code/SoS/multivariate_genome/MASH/mixture_prior.ipynb b/code/SoS/multivariate_genome/MASH/mixture_prior.ipynb index c9290ddb1..36e6b8242 100644 --- a/code/SoS/multivariate_genome/MASH/mixture_prior.ipynb +++ b/code/SoS/multivariate_genome/MASH/mixture_prior.ipynb @@ -424,11 +424,7 @@ "if len(output_prefix) == 0:\n", " output_prefix = f\"{data:bn}\"\n", "prior_data = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.prior.rds\")\n", - "vhat_data = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.V_{vhat}.rds\")\n", - "\n", - "def sort_uniq(seq):\n", - " seen = set()\n", - " return [x for x in seq if not (x in seen or seen.add(x))]" + "vhat_data = file_target(f\"{cwd:a}/{output_prefix}.{effect_model}.V_{vhat}.rds\")" ] }, { @@ -448,16 +444,16 @@ }, "outputs": [], "source": [ - "# Perform FLASH analysis with non-negative factor constraint\n", "[flash]\n", "input: data\n", "output: f\"{cwd}/{output_prefix}.flash.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", - " dat = readRDS(${_input:r})\n", - " dat = mashr::mash_set_data(dat$strong.b, Shat=dat$strong.s, alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3)\n", - " res = mashr::cov_flash(dat, factors=\"default\", remove_singleton=${\"TRUE\" if \"canonical\" in mixture_components else \"FALSE\"}, output_model=\"${_output:n}.model.rds\")\n", - " saveRDS(res, ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_covariance.R \\\n", + " --data ${_input} \\\n", + " --component flash \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -468,16 +464,16 @@ }, "outputs": [], "source": [ - "# Perform FLASH analysis with non-negative factor constraint\n", "[flash_nonneg]\n", "input: data\n", "output: f\"{cwd}/{output_prefix}.flash_nonneg.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", - " dat = readRDS(${_input:r})\n", - " dat = mashr::mash_set_data(dat$strong.b, Shat=dat$strong.s, alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3)\n", - " res = mashr::cov_flash(dat, factors=\"nonneg\", remove_singleton=${\"TRUE\" if \"canonical\" in mixture_components else \"FALSE\"}, output_model=\"${_output:n}.model.rds\")\n", - " saveRDS(res, ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_covariance.R \\\n", + " --data ${_input} \\\n", + " --component flash_nonneg \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -494,12 +490,14 @@ "parameter: npc = 2\n", "input: data\n", "output: f\"{cwd}/{output_prefix}.pca.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", - " dat = readRDS(${_input:r})\n", - " dat = mashr::mash_set_data(dat$strong.b, Shat=dat$strong.s, alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3)\n", - " res = mashr::cov_pca(dat, ${npc})\n", - " saveRDS(res, ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_covariance.R \\\n", + " --data ${_input} \\\n", + " --component pca \\\n", + " --npc ${npc} \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -513,13 +511,13 @@ "[canonical]\n", "input: data\n", "output: f\"{cwd}/{output_prefix}.canonical.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", - " library(\"mashr\")\n", - " dat = readRDS(${_input:r})\n", - " dat = mashr::mash_set_data(dat$strong.b, Shat=dat$strong.s, alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3)\n", - " res = mashr::cov_canonical(dat)\n", - " saveRDS(res, ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_covariance.R \\\n", + " --data ${_input} \\\n", + " --component canonical \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -543,10 +541,13 @@ "[vhat_identity]\n", "input: data\n", "output: f'{vhat_data:nn}.V_identity.rds'\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " dat = readRDS(${_input:r})\n", - " saveRDS(diag(ncol(dat$random.b)), ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_vhat.R \\\n", + " --data ${_input} \\\n", + " --method identity \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -557,16 +558,17 @@ }, "outputs": [], "source": [ - "# V estimate: \"simple\" method (using null z-scores)\n", + "# V estimate: \"simple\" method (null z-scores)\n", "[vhat_simple]\n", "input: data\n", "output: f'{vhat_data:nn}.V_simple.rds'\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " library(mashr)\n", - " dat = readRDS(${_input:r})\n", - " vhat = estimate_null_correlation_simple(mash_set_data(dat$null.b, Shat=dat$null.s, alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3))\n", - " saveRDS(vhat, ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_vhat.R \\\n", + " --data ${_input} \\\n", + " --method simple \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -577,74 +579,24 @@ }, "outputs": [], "source": [ - "# V estimate: \"mle\" method\n", + "# V estimate: \"mle\" method (mash_estimate_corr_em on a random subset; needs the prior U)\n", "[vhat_mle]\n", "# number of samples to use\n", "parameter: n_subset = 6000\n", "# maximum number of iterations\n", "parameter: max_iter = 6\n", - "\n", "input: data, prior_data\n", "output: f'{vhat_data:nn}.V_mle.rds'\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " library(mashr)\n", - " dat = readRDS(${_input[0]:r})\n", - " # choose random subset\n", - " set.seed(1)\n", - " random.subset = sample(1:nrow(dat$random.b), min(${n_subset}, nrow(dat$random.b)))\n", - " random.subset = mash_set_data(dat$random.b[random.subset,], dat$random.s[random.subset,], alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3)\n", - " # estimate V mle\n", - " vhatprior = mash_estimate_corr_em(random.subset, readRDS(${_input[1]:r})$U, max_iter = ${max_iter})\n", - " vhat = vhatprior$V\n", - " saveRDS(vhat, ${_output:r})" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "# Estimate each V separately via corshrink\n", - "[vhat_corshrink_xcondition_1]\n", - "# Utility script\n", - "parameter: util_script = path('/project/mstephens/gtex/scripts/SumstatQuery.R')\n", - "# List of genes to analyze\n", - "parameter: gene_list = path()\n", - "\n", - "fail_if(not gene_list.is_file(), msg = 'Please specify valid path for --gene-list')\n", - "fail_if(not util_script.is_file() and len(str(util_script)), msg = 'Please specify valid path for --util-script')\n", - "genes = sort_uniq([x.strip().strip('\"') for x in open(f'{gene_list:a}').readlines() if not x.strip().startswith('#')])\n", - "\n", - "\n", - "depends: R_library(\"CorShrink\")\n", - "input: data, for_each = 'genes'\n", - "output: f'{vhat_data:nn}/{vhat_data:bnn}_V_corshrink_{_genes}.rds'\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " source(${util_script:r})\n", - " CorShrink_sum = function(gene, database, z_thresh = 2){\n", - " print(gene)\n", - " dat <- GetSS(gene, database)\n", - " z = dat$\"z-score\"\n", - " max_absz = apply(abs(z), 1, max)\n", - " nullish = which(max_absz < z_thresh)\n", - " # if (length(nullish) < ncol(z)) {\n", - " # stop(\"not enough null data to estimate null correlation\")\n", - " # }\n", - " if (length(nullish) <= 1){\n", - " mat = diag(ncol(z))\n", - " } else {\n", - " nullish_z = z[nullish, ] \n", - " mat = as.matrix(CorShrink::CorShrinkData(nullish_z, ash.control = list(mixcompdist = \"halfuniform\"))$cor)\n", - " }\n", - " return(mat)\n", - " }\n", - " V = Corshrink_sum(\"${_genes}\", ${data:r})\n", - " saveRDS(V, ${_output:r})" + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_vhat.R \\\n", + " --data ${_input[0]} \\\n", + " --method mle \\\n", + " --prior-data ${_input[1]} \\\n", + " --n-subset ${n_subset} \\\n", + " --max-iter ${max_iter} \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -655,43 +607,17 @@ }, "outputs": [], "source": [ - "# Estimate each V separately via \"simple\" method\n", - "[vhat_simple_specific_1]\n", - "# Utility script\n", - "parameter: util_script = path('/project/mstephens/gtex/scripts/SumstatQuery.R')\n", - "# List of genes to analyze\n", - "parameter: gene_list = path()\n", - "\n", - "fail_if(not gene_list.is_file(), msg = 'Please specify valid path for --gene-list')\n", - "fail_if(not util_script.is_file() and len(str(util_script)), msg = 'Please specify valid path for --util-script')\n", - "genes = sort_uniq([x.strip().strip('\"') for x in open(f'{gene_list:a}').readlines() if not x.strip().startswith('#')])\n", - "\n", - "depends: R_library(\"Matrix\")\n", - "input: data, for_each = 'genes'\n", - "output: f'{vhat_data:nn}/{vhat_data:bnn}_V_simple_{_genes}.rds'\n", - "\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " source(${util_script:r})\n", - " simple_V = function(gene, database, z_thresh = 2){\n", - " print(gene)\n", - " dat <- GetSS(gene, database)\n", - " z = dat$\"z-score\"\n", - " max_absz = apply(abs(z), 1, max)\n", - " nullish = which(max_absz < z_thresh)\n", - " # if (length(nullish) < ncol(z)) {\n", - " # stop(\"not enough null data to estimate null correlation\")\n", - " # }\n", - " if (length(nullish) <= 1){\n", - " mat = diag(ncol(z))\n", - " } else {\n", - " nullish_z = z[nullish, ]\n", - " mat = as.matrix(Matrix::nearPD(as.matrix(cov(nullish_z)), conv.tol=1e-06, doSym = TRUE, corr=TRUE)$mat)\n", - " }\n", - " return(mat)\n", - " }\n", - " V = simple_V(\"${_genes}\", ${data:r})\n", - " saveRDS(V, ${_output:r})" + "# V estimate: \"corshrink\" adaptive-shrinkage null correlation (run globally on the null set; the legacy per-gene GTEx SumstatQuery path is not portable)\n", + "[vhat_corshrink_xcondition]\n", + "input: data\n", + "output: f'{vhat_data:nn}.V_vhat_corshrink_xcondition.rds'\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_vhat.R \\\n", + " --data ${_input} \\\n", + " --method corshrink \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -702,28 +628,17 @@ }, "outputs": [], "source": [ - "# Consolidate Vhat into one file\n", - "[vhat_corshrink_xcondition_2, vhat_simple_specific_2]\n", - "depends: R_library(\"parallel\")\n", - "# List of genes to analyze\n", - "parameter: gene_list = path()\n", - "\n", - "fail_if(not gene_list.is_file(), msg = 'Please specify valid path for --gene-list')\n", - "genes = paths([x.strip().strip('\"') for x in open(f'{gene_list:a}').readlines() if not x.strip().startswith('#')])\n", - "\n", - "\n", - "input: group_by = 'all'\n", - "output: f\"{vhat_data:nn}.V_{step_name.rsplit('_',1)[0]}.rds\"\n", - "\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", workdir = cwd, stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " library(parallel)\n", - " files = sapply(c(${genes:r,}), function(g) paste0(c(${_input[0]:adr}), '/', g, '.rds'), USE.NAMES=FALSE)\n", - " V = mclapply(files, function(i){ readRDS(i) }, mc.cores = 1)\n", - " R = dim(V[[1]])[1]\n", - " L = length(V)\n", - " V.array = array(as.numeric(unlist(V)), dim=c(R, R, L))\n", - " saveRDS(V.array, ${_output:ar})" + "# V estimate: \"simple_specific\" nearPD(cov(nullZ)) (run globally on the null set; legacy per-gene GTEx path not portable)\n", + "[vhat_simple_specific]\n", + "input: data\n", + "output: f'{vhat_data:nn}.V_vhat_simple_specific.rds'\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_vhat.R \\\n", + " --data ${_input} \\\n", + " --method simple_specific \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -744,42 +659,20 @@ }, "outputs": [], "source": [ - "# Latest update: May/2023\n", + "# Prior engine: udr ED update (opt-in; known numerical issues)\n", "[ud]\n", - "# Options are \"ted\", \"ed\", \n", - "parameter: unconstrained_prior = \"ted\"\n", - "input:[data, vhat_data if vhat != \"mle\" else f'{vhat_data:nn}.V_simple.rds'] \n", + "input: [data, vhat_data if vhat != \"mle\" else f'{vhat_data:nn}.V_simple.rds'] + [f\"{cwd}/{output_prefix}.{m}.rds\" for m in mixture_components]\n", "output: prior_data\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " library(stringr)\n", - " library(udr)\n", - " library(mashr)\n", - "\n", - " rds_files = c(${_input:r,})\n", - " # mash data \n", - " dat = readRDS(rds_files[1])\n", - " vhat = readRDS(rds_files[2])\n", - "\n", - " # Fit mixture model using udr package\n", - " mash_data = mash_set_data(dat$strong.b, Shat=dat$strong.s, V=vhat, alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3)\n", - " # Canonical matrices\n", - " U.can = cov_canonical(mash_data) \n", - "\n", - " set.seed(999)\n", - " # Penalty strength\n", - " lambda = ncol(dat$strong.z)\n", - " # Initialize udr\n", - " fit0 <- ud_init(mash_data, n_unconstrained = 50, U_scaled = U.can)\n", - " # Fit udr and use penalty as default as suggested by Yunqi\n", - " # penalty is necessary in small sample size case, and there won't be a difference in large sample size \n", - " fit2 = ud_fit(fit0, control = list(unconstrained.update = \"${unconstrained_prior}\", scaled.update = \"fa\", resid.update = 'none', \n", - " lambda =lambda, penalty.type = \"iw\", maxiter=1e3, tol = 1e-2, tol.lik = 1e-2))\n", - "\n", - " # extract data-driven covariance from udr model. (A list of covariance matrices)\n", - " U.ud <- lapply(fit2$U,function (e) \"[[\"(e,\"mat\")) \n", - "\n", - " saveRDS(list(U=U.ud, w=fit2$w, loglik=fit2$loglik), ${_output:r})" + "comp_files = \",\".join([f\"{cwd}/{output_prefix}.{m}.rds\" for m in mixture_components])\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_prior.R \\\n", + " --data ${_input[0]} \\\n", + " --engine ud \\\n", + " --vhat-data ${_input[1]} \\\n", + " --component-files ${comp_files} \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -790,46 +683,20 @@ }, "outputs": [], "source": [ + "# Prior engine: udr TED update (opt-in; needs i.i.d./z-scale data)\n", "[ud_unconstrained]\n", - "# Method is `ed` or `ted`\n", - "parameter: ud_method = \"ed\"\n", - "# A typical choice is to estimate scales only for canonical components\n", - "parameter: scale_only = []\n", - "# Tolerance for change in likelihood\n", - "parameter: ud_tol_lik = 1e-3\n", "input: [data, vhat_data if vhat != \"mle\" else f'{vhat_data:nn}.V_simple.rds'] + [f\"{cwd}/{output_prefix}.{m}.rds\" for m in mixture_components]\n", "output: prior_data\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " library(stringr)\n", - " rds_files = c(${_input:r,})\n", - " dat = readRDS(rds_files[1])\n", - " vhat = readRDS(rds_files[2])\n", - " mash_data = mash_set_data(dat$strong.b, Shat=dat$strong.s, V=vhat, alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3)\n", - " # U is different from mashr pipeline, here I kept the later one\n", - " # U = list(XtX = dat$XtX)\n", - " U = list(XtX = t(mash_data$Bhat) %*% mash_data$Bhat / nrow(mash_data$Bhat))\n", - "\n", - " U_scaled = list()\n", - " mixture_components = c(${paths(mixture_components):r,})\n", - " scale_only = c(${paths(scale_only):r,})\n", - " scale_idx = which(mixture_components %in% scale_only )\n", - " for (f in 3:length(rds_files) ) {\n", - " if ((f - 1) %in% scale_idx ) {\n", - " U_scaled = c(U_scaled, readRDS(rds_files[f]))\n", - " } else {\n", - " U = c(U, readRDS(rds_files[f]))\n", - " }\n", - " }\n", - " \n", - " # Fit mixture model using udr package\n", - " library(udr)\n", - " message(paste(\"Running ${ud_method.upper()} via udr package for\", length(U), \"mixture components\"))\n", - " f0 = ud_init(X = as.matrix(dat$strong.z), V = V, U_scaled = U_scaled, U_unconstrained = U, n_rank1=0)\n", - " res = ud_fit(f0, X = na.omit(f0$X), control = list(unconstrained.update = \"ed\", resid.update = 'none', scaled.update = \"fa\", maxiter=5000, tol.lik = ${ud_tol_lik}), verbose=TRUE)\n", - " res_ted = ud_fit(f0, X = na.omit(f0$X), control = list(unconstrained.update = \"ted \", resid.update = 'none', scaled.update = \"fa\", maxiter=5000, tol.lik = ${ud_tol_lik}), verbose=TRUE)\n", - "\n", - " saveRDS(list(U=res$U, w=res$w, loglik=res$loglik), ${_output:r})" + "comp_files = \",\".join([f\"{cwd}/{output_prefix}.{m}.rds\" for m in mixture_components])\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_prior.R \\\n", + " --data ${_input[0]} \\\n", + " --engine ud_ted \\\n", + " --vhat-data ${_input[1]} \\\n", + " --component-files ${comp_files} \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -840,26 +707,20 @@ }, "outputs": [], "source": [ + "# Prior engine: mashr extreme deconvolution (the exported bovy ED)\n", "[ed_bovy]\n", - "parameter: ed_tol = 1e-6\n", "input: [data, vhat_data if vhat != \"mle\" else f'{vhat_data:nn}.V_simple.rds'] + [f\"{cwd}/{output_prefix}.{m}.rds\" for m in mixture_components]\n", "output: prior_data\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}' \n", - "R: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", - " library(mashr)\n", - " rds_files = c(${_input:r,})\n", - " dat = readRDS(rds_files[1])\n", - " vhat = readRDS(rds_files[2])\n", - " mash_data = mash_set_data(dat$strong.b, Shat=dat$strong.s, V=vhat, alpha=${1 if effect_model == 'EZ' else 0}, zero_Bhat_Shat_reset = 1E3)\n", - " # U is different from mashr pipeline, here I kept the later one\n", - " # U = list(XtX = dat$XtX)\n", - " U = list(XtX = t(mash_data$Bhat) %*% mash_data$Bhat / nrow(mash_data$Bhat))\n", - " \n", - " for (f in rds_files[3:length(rds_files)]) U = c(U, readRDS(f))\n", - " # Fit mixture model using ED code by J. Bovy\n", - " message(paste(\"Running ED via J. Bovy's code for\", length(U), \"mixture components\"))\n", - " res = mashr:::bovy_wrapper(mash_data, U, logfile=${_output:nr}, tol = ${ed_tol})\n", - " saveRDS(list(U=res$Ulist, w=res$pi, loglik=scan(\"${_output:n}_loglike.log\")), ${_output:r})" + "comp_files = \",\".join([f\"{cwd}/{output_prefix}.{m}.rds\" for m in mixture_components])\n", + "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, tags = f'{step_name}_{_output:bn}'\n", + "bash: expand = \"${ }\", stderr = f\"{_output:n}.stderr\", stdout = f\"{_output:n}.stdout\", container = container\n", + " Rscript code/script/pecotmr_integration/mash_prior.R \\\n", + " --data ${_input[0]} \\\n", + " --engine cov_ed \\\n", + " --vhat-data ${_input[1]} \\\n", + " --component-files ${comp_files} \\\n", + " --effect-model ${effect_model} \\\n", + " --output ${_output}" ] }, { @@ -900,75 +761,15 @@ "parameter: name = \"\"\n", "input: data\n", "output: f'{cwd:a}/{_input:bn}{(\"_\" + name.replace(\"$\", \"_\")) if name != \"\" else \"\"}.pdf'\n", - "R: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", - " library(reshape2)\n", - " library(ggplot2)\n", - " plot_sharing = function(X, col = 'black', to_cor=FALSE, title=\"\", remove_names=F) {\n", - " clrs <- colorRampPalette(rev(c(\"#D73027\",\"#FC8D59\",\"#FEE090\",\"#FFFFBF\",\n", - " \"#E0F3F8\",\"#91BFDB\",\"#4575B4\")))(128)\n", - " if (to_cor) lat <- cov2cor(X)\n", - " else lat = X/max(diag(X))\n", - " lat[lower.tri(lat)] <- NA\n", - " n <- nrow(lat)\n", - " if (remove_names) {\n", - " colnames(lat) = paste('t',1:n, sep = '')\n", - " rownames(lat) = paste('t',1:n, sep = '')\n", - " }\n", - " melted_cormat <- melt(lat[n:1,], na.rm = TRUE)\n", - " p = ggplot(data = melted_cormat, aes(Var2, Var1, fill = value))+\n", - " geom_tile(color = \"white\")+ggtitle(title) + \n", - " scale_fill_gradientn(colors = clrs, limit = c(-1,1), space = \"Lab\") +\n", - " theme_minimal()+ \n", - " coord_fixed() +\n", - " theme(axis.title.x = element_blank(),\n", - " axis.title.y = element_blank(),\n", - " axis.text.x = element_text(color=col, size=8,angle=45,hjust=1),\n", - " axis.text.y = element_text(color=rev(col), size=8),\n", - " title =element_text(size=10),\n", - " # panel.grid.major = element_blank(),\n", - " panel.border = element_blank(),\n", - " panel.background = element_blank(),\n", - " axis.ticks = element_blank(),\n", - " legend.justification = c(1, 0),\n", - " legend.position = c(0.6, 0),\n", - " legend.direction = \"horizontal\")+\n", - " guides(fill = guide_colorbar(title=\"\", barwidth = 7, barheight = 1,\n", - " title.position = \"top\", title.hjust = 0.5))\n", - " if(remove_names){\n", - " p = p + scale_x_discrete(labels= 1:n) + scale_y_discrete(labels= n:1)\n", - " }\n", - " return(p)\n", - " }\n", - " \n", - " dat = readRDS(${_input:r})\n", - " name = \"${name}\"\n", - " if (name != \"\") {\n", - " if (is.null(dat[[name]])) stop(\"Cannot find data ${name} in ${_input}\")\n", - " dat = dat[[name]]\n", - " }\n", - " if (is.null(names(dat$U))) names(dat$U) = paste0(\"Comp_\", 1:length(dat$U))\n", - " meta = data.frame(names(dat$U), dat$w, stringsAsFactors=F)\n", - " colnames(meta) = c(\"U\", \"w\")\n", - " tol = ${tol}\n", - " n_comp = length(meta$U[which(meta$w>tol)])\n", - " meta = head(meta[order(meta[,2], decreasing = T),], ${max_comp if max_comp > 1 else \"nrow(meta)\"})\n", - " message(paste(n_comp, \"components out of\", length(dat$w), \"total components have weight greater than\", tol))\n", - " res = list()\n", - " for (i in 1:n_comp) {\n", - " title = paste(meta$U[i], \"w =\", round(meta$w[i], 6))\n", - " ##Handle updated udr data structure\n", - " if(is.list(dat$U[[meta$U[i]]])){\n", - " res[[i]] = plot_sharing(dat$U[[meta$U[i]]]$mat, to_cor = ${\"T\" if to_cor else \"F\"}, title=title, remove_names = ${\"TRUE\" if remove_label else \"FALSE\"})\n", - " } else if(is.matrix(dat$U[[meta$U[i]]])){\n", - " res[[i]] = plot_sharing(dat$U[[meta$U[i]]], to_cor = ${\"T\" if to_cor else \"F\"}, title=title, remove_names = ${\"TRUE\" if remove_label else \"FALSE\"})\n", - " }\n", - " }\n", - " unit = 4\n", - " n_col = 5\n", - " n_row = ceiling(n_comp / n_col)\n", - " pdf(${_output:r}, width = unit * n_col, height = unit * n_row)\n", - " do.call(gridExtra::grid.arrange, c(res, list(ncol = n_col, nrow = n_row, bottom = \"Data source: readRDS(${_input:br})${('$'+name) if name else ''}\")))\n", - " dev.off()" + "bash: expand = \"${ }\", stderr = f'{_output:n}.stderr', stdout = f'{_output:n}.stdout', container = container\n", + " Rscript code/script/pecotmr_integration/mash_plot_prior.R \\\n", + " --data ${_input} \\\n", + " --max-comp ${max_comp} \\\n", + " --tol ${tol} \\\n", + " --name \"${name}\" \\\n", + " ${'--to-cor' if to_cor else ''} \\\n", + " ${'--remove-label' if remove_label else ''} \\\n", + " --output ${_output}" ] } ], @@ -1000,4 +801,4 @@ }, "nbformat": 4, "nbformat_minor": 4 -} \ No newline at end of file +} diff --git a/code/SoS/pecotmr_integration/SuSiE_enloc.ipynb b/code/SoS/pecotmr_integration/SuSiE_enloc.ipynb index d10d51339..9a1efbe56 100644 --- a/code/SoS/pecotmr_integration/SuSiE_enloc.ipynb +++ b/code/SoS/pecotmr_integration/SuSiE_enloc.ipynb @@ -180,7 +180,7 @@ "cell_type": "markdown", "metadata": {}, "source": [ - "### Output\n\nOutput file: `{cwd}/{step_name}/{name}.{context}@{gene}.coloc.rds`\n\n```r\nres <- readRDS(\"output/output/susie_coloc/susie_coloc/protocol_example.enloc.Knight_eQTL_brain@ENSG00000142798.coloc.rds\")\n\nlength(res) # 1\nnames(res) # [1] \"ENSG00000142798\"\n\nstr(res, max.level = 2)\n# List of 1\n# $ ENSG00000142798:List of 2\n# ..$ (unnamed) : chr \"No coloc results due to the absence of a GWAS log Bayes factor matrix filtered by prior tolerance.\"\n# ..$ analysis_region: chr \"chr1_20110062_22020160\"\n\nres$ENSG00000142798$analysis_region # \"chr1_20110062_22020160\"\n```\n\nThe output is a named list with one entry per gene. Each gene entry contains:\n\n- **`[[1]]` (unnamed)**: the colocalization result \u2014 either a data.frame of PP values (positive result) or a character string explaining why coloc was skipped.\n- **`$analysis_region`**: the genomic block ID (e.g. `\"chr1_20110062_22020160\"`) that was analyzed.\n\nWhen colocalization runs successfully, `res[[gene]][[1]]` is a data.frame with one row per SuSiE effect pair (xQTL effect \u00d7 GWAS effect) and columns:\n\n| Column | Description |\n|--------|-------------|\n| `nsnps` | Number of variants in the shared analysis window |\n| `PP.H0.abf` | Posterior probability: neither trait has a causal variant in this region |\n| `PP.H1.abf` | Posterior probability: only xQTL has a causal variant |\n| `PP.H2.abf` | Posterior probability: only GWAS has a causal variant |\n| `PP.H3.abf` | Posterior probability: both have causal variants, but different ones |\n| `PP.H4.abf` | Posterior probability: both traits share the same causal variant (colocalization) |\n| `hit1` | Top variant ID from the xQTL credible set |\n| `hit2` | Top variant ID from the GWAS credible set |\n\nPP.H0 + PP.H1 + PP.H2 + PP.H3 + PP.H4 = 1. **PP.H4.abf > 0.8** is the standard threshold for strong colocalization evidence.\n\n> **Note on toy data**: this example returns a message string instead of a data.frame because the toy GWAS fine-mapping signal in this region is too weak (max PIP \u2248 0.04, no credible set). This is an expected negative result for a toy dataset, not a pipeline error." + "### Output\n\nOutput file: `{cwd}/{step_name}/{name}.{context}@{gene}.coloc.rds`\n\n```r\nres <- readRDS(\"output/output/susie_coloc/susie_coloc/protocol_example.enloc.Knight_eQTL_brain@ENSG00000142798.coloc.rds\")\n\nlength(res) # 1\nnames(res) # [1] \"ENSG00000142798\"\n\nstr(res, max.level = 2)\n# List of 1\n# $ ENSG00000142798:List of 2\n# ..$ (unnamed) : chr \"No coloc results due to the absence of a GWAS log Bayes factor matrix filtered by prior tolerance.\"\n# ..$ analysis_region: chr \"chr1_20110062_22020160\"\n\nres$ENSG00000142798$analysis_region # \"chr1_20110062_22020160\"\n```\n\nThe output is a named list with one entry per gene. Each gene entry contains:\n\n- **`[[1]]` (unnamed)**: the colocalization result — either a data.frame of PP values (positive result) or a character string explaining why coloc was skipped.\n- **`$analysis_region`**: the genomic block ID (e.g. `\"chr1_20110062_22020160\"`) that was analyzed.\n\nWhen colocalization runs successfully, `res[[gene]][[1]]` is a data.frame with one row per SuSiE effect pair (xQTL effect × GWAS effect) and columns:\n\n| Column | Description |\n|--------|-------------|\n| `nsnps` | Number of variants in the shared analysis window |\n| `PP.H0.abf` | Posterior probability: neither trait has a causal variant in this region |\n| `PP.H1.abf` | Posterior probability: only xQTL has a causal variant |\n| `PP.H2.abf` | Posterior probability: only GWAS has a causal variant |\n| `PP.H3.abf` | Posterior probability: both have causal variants, but different ones |\n| `PP.H4.abf` | Posterior probability: both traits share the same causal variant (colocalization) |\n| `hit1` | Top variant ID from the xQTL credible set |\n| `hit2` | Top variant ID from the GWAS credible set |\n\nPP.H0 + PP.H1 + PP.H2 + PP.H3 + PP.H4 = 1. **PP.H4.abf > 0.8** is the standard threshold for strong colocalization evidence.\n\n> **Note on toy data**: this example returns a message string instead of a data.frame because the toy GWAS fine-mapping signal in this region is too weak (max PIP ≈ 0.04, no credible set). This is an expected negative result for a toy dataset, not a pipeline error." ] }, { @@ -238,7 +238,6 @@ "# It is required to input the name of the analysis\n", "parameter: name = f\"{xqtl_meta_data:bnn}.{gwas_meta_data:bnn}\"\n", "parameter: container = \"\"\n", - "import re\n", "# For cluster jobs, number commands to run per job\n", "parameter: job_size = 200\n", "# Wall clock time expected\n", @@ -273,105 +272,7 @@ "# the analysis would be focused on the union of provides region list and region names\n", "parameter: region_name = []\n", "# use conditions_top_loci_minp column or not, which can reduce a lot computing resource by pick top 1 isoform\n", - "parameter: minp = False\n", - "import os\n", - "import pandas as pd\n", - "import re\n", - "def group_by_region(lst, partition):\n", - " # from itertools import accumulate\n", - " # partition = [len(x) for x in partition]\n", - " # Compute the cumulative sums once\n", - " # cumsum_vector = list(accumulate(partition))\n", - " # Use slicing based on the cumulative sums\n", - " # return [lst[(cumsum_vector[i-1] if i > 0 else 0):cumsum_vector[i]] for i in range(len(partition))]\n", - " return partition\n", - "\n", - "def make_unique_data(data):\n", - " return ','.join(set(data.split(',')))\n", - "\n", - "def generate_meta_dataframe(meta_data_path):\n", - " \"\"\"Generate a new long metadata by converting to context:analysis_name (1:1).\"\"\"\n", - " meta = pd.read_csv(meta_data_path, sep='\\t')\n", - " new_meta = pd.DataFrame()\n", - " contexts = pd.unique(meta['context'].str.split(',', expand=True).stack().str.strip())\n", - "\n", - " for context in contexts:\n", - " if not isinstance(context, str):\n", - " continue\n", - " mask = meta['context'].str.contains(context)\n", - " tmp = pd.DataFrame({\n", - " 'context': [context],\n", - " 'analysis_name': [','.join(meta.loc[mask, 'analysis_name'])]\n", - " })\n", - " new_meta = pd.concat([new_meta, tmp], ignore_index=True)\n", - "\n", - " return new_meta\n", - "\n", - "def generate_condition_based_dataframe(xqtl_df, minp):\n", - " \"\"\"Generate a new long table by converting to condition and region:original_data (1:1).\"\"\"\n", - " # only consider the QTL contexts that have top loci data\n", - " condition_column = 'conditions_top_loci_minp' if minp else 'conditions_top_loci'\n", - " conditions = pd.unique(xqtl_df[condition_column].str.split(',', expand=True).stack().str.strip())\n", - " new_df = pd.DataFrame()\n", - "\n", - " for condition in conditions:\n", - " if not isinstance(condition, str):\n", - " continue\n", - " escaped_condition = re.escape(condition)\n", - " mask = xqtl_df[condition_column].str.contains(escaped_condition, case=False, regex=True)\n", - " \n", - " # Iterate through each unique region in the filtered data\n", - " unique_regions = pd.unique(xqtl_df.loc[mask, 'region_id'])\n", - " for region_id in unique_regions:\n", - " region_mask = (xqtl_df['region_id'] == region_id) & mask\n", - " tmp = pd.DataFrame({\n", - " 'condition': [condition],\n", - " 'region_id': [region_id],\n", - " 'QTL_original_data': [','.join(xqtl_df.loc[region_mask, 'original_data'])],\n", - " 'GWAS_original_data': [','.join(xqtl_df.loc[region_mask, 'block_data'])]\n", - " })\n", - " new_df = pd.concat([new_df, tmp], ignore_index=True)\n", - "\n", - " return new_df\n", - "\n", - "\n", - "def merge_and_filter_dfs(new_df, new_meta):\n", - " \"\"\"Merge and filter the dataframes based on condition/context where context is a substring of condition, and analysis_name to pick the corresponding original files.\"\"\"\n", - " # Explode the QTL data into separate rows\n", - " new_df = new_df.set_index(['condition', 'region_id', 'GWAS_original_data'])['QTL_original_data'].str.split(',', expand=True).stack().reset_index(name='QTL_original_data').drop('level_3', axis=1)\n", - " new_df['analysis_name_prefix'] = new_df['QTL_original_data'] # bugfix: keep full filename; matched via substring below, not position[0], since real file names are '{prefix}.{cohort}.{analysis_name}.{gene}...rds' not '{analysis_name}...rds'\n", - "\n", - " # Create a custom merge logic to match context as a substring of condition\n", - " def custom_merge(row, df_meta):\n", - " # Filter meta dataframe to find any context that is part of the condition string\n", - " sub_df = df_meta[df_meta['context'].apply(lambda x: x in row['condition'])]\n", - " if not sub_df.empty:\n", - " return sub_df\n", - " else:\n", - " return pd.DataFrame(columns=df_meta.columns) # Return an empty DataFrame with the same columns if no match found\n", - "\n", - " # Apply custom merge function row-wise and concatenate results\n", - " results = [custom_merge(row, new_meta) for index, row in new_df.iterrows()]\n", - " merged_df = pd.concat(results, keys=new_df.index).reset_index(level=1, drop=True).join(new_df, how='outer')\n", - "\n", - " # Filter rows where analysis_name_prefix matches analysis_name exactly\n", - " filtered_df = merged_df[merged_df.apply(lambda r: str(r['analysis_name']).strip().lower() in str(r['analysis_name_prefix']).lower(), axis=1)] # bugfix: case-insensitive substring match instead of exact-equality on a mis-parsed prefix\n", - "\n", - " # Drop unnecessary columns and duplicates\n", - " filtered_df = filtered_df.drop(columns=['analysis_name_prefix', 'context']).drop_duplicates()\n", - " filtered_df['GWAS_original_data'] = filtered_df['GWAS_original_data'].apply(make_unique_data)\n", - "\n", - " return filtered_df\n", - "\n", - "def prepare_final_paths(filtered_df, qtl_path, gwas_path):\n", - " \"\"\"Prepare final paths for QTL and GWAS original data.\"\"\"\n", - " filtered_df['QTL_original_data'] = filtered_df['QTL_original_data'].apply(\n", - " lambda x: ','.join(f\"{qtl_path}/{file_name.strip()}\" for file_name in x.split(','))\n", - " )\n", - " filtered_df['GWAS_original_data'] = filtered_df['GWAS_original_data'].apply(\n", - " lambda x: ','.join(f\"{gwas_path}/{file_name.strip()}\" for file_name in x.split(','))\n", - " )\n", - " return filtered_df" + "parameter: minp = False\n" ] }, { @@ -383,98 +284,27 @@ }, "outputs": [], "source": [ - "# get overlapped regions by gene and block region for enrichment analysis\n", - "[get_analysis_regions: shared = \"regional_data\"]\n", - "import pandas as pd\n", - "\n", - "def process_dataframes_with_toploci(xqtl_meta_data, gwas_meta_data):\n", - " \"\"\"Process the XQTL and GWAS dataframes.\"\"\"\n", - " xqtl_df = pd.read_csv(xqtl_meta_data, sep=\"\\t\")\n", - " # filter xQTL data with the ones have overlapped top loci variants with GWAS data\n", - " xqtl_df = xqtl_df[xqtl_df['conditions_top_loci_minp' if minp else 'conditions_top_loci'].notna()]\n", - "\n", - " gwas_df = pd.read_csv(gwas_meta_data, sep=\"\\t\")\n", - " gwas_df = gwas_df[gwas_df['conditions_top_loci'].notna()]\n", - " # e.g. gwas_finemapping_obj = ['AD_Bellenguez_2022', 'single_effect_regression', 'susie_result_trimmed']\n", - " # filter gwas data with find variants in specified cohort 'AD_Bellenguez_2022' and method 'single_effect_regression'\n", - " gwas_finemapping_obj_filtered = [obj for obj in gwas_finemapping_obj if obj != 'susie_result_trimmed']\n", - " if len(gwas_finemapping_obj_filtered) > 0:\n", - " pattern = '|'.join(gwas_finemapping_obj_filtered)\n", - " gwas_df = gwas_df[gwas_df['conditions_top_loci'].str.contains(pattern)]\n", - "\n", - " xqtl_df = overlapped_analysis_region(xqtl_df, gwas_df)\n", - " return xqtl_df, gwas_df\n", - "\n", - "\n", - "\n", - "def overlapped_analysis_region(xqtl_df, gwas_df):\n", - " # Create an empty dataframe to store overlapping xQTL records\n", - " overlapped_xqtl_df = pd.DataFrame()\n", - " \n", - " # Iterate over each row in the GWAS dataframe\n", - " for index, gwas_row in gwas_df.iterrows():\n", - " gwas_chr = gwas_row['#chr']\n", - " gwas_start = gwas_row['start']\n", - " gwas_end = gwas_row['end']\n", - " gwas_block_id = gwas_row['original_data'] # Assuming each GWAS row has a unique block ID\n", - " \n", - " # Filter xQTL dataframe for the same chromosome\n", - " same_chr_xqtl_df = xqtl_df[xqtl_df['#chr'] == gwas_chr]\n", - " \n", - " # Find overlapping xQTL regions with the current GWAS region\n", - " overlapping_xqtl = same_chr_xqtl_df[((same_chr_xqtl_df['start'] <= gwas_end) & \n", - " (same_chr_xqtl_df['end'] >= gwas_start))].copy() # Add .copy() to avoid SettingWithCopyWarning\n", - " \n", - " # Check if there are any overlapping xQTLs\n", - " if not overlapping_xqtl.empty:\n", - " # Use .loc to safely assign 'block_data' to avoid the SettingWithCopyWarning\n", - " overlapping_xqtl.loc[:, 'block_data'] = gwas_block_id\n", - " \n", - " # Append the overlapping xQTLs to the accumulated dataframe\n", - " overlapped_xqtl_df = pd.concat([overlapped_xqtl_df, overlapping_xqtl], ignore_index=True)\n", - " \n", - " # Group by xQTL region and concatenate 'block_data'\n", - " overlapped_xqtl_df['block_data'] = overlapped_xqtl_df.groupby(['#chr', 'start', 'end'])['block_data'].transform(lambda x: ','.join(x))\n", - " overlapped_xqtl_df = overlapped_xqtl_df.drop_duplicates().reset_index(drop=True)\n", - "\n", - " return overlapped_xqtl_df\n", - "\n", - "\n", - "xqtl_df, gwas_df = process_dataframes_with_toploci(xqtl_meta_data, gwas_meta_data)\n", - "\n", - "region_ids=[]\n", - "# If region_list is provided, read the file and extract IDs\n", - "if not region_list.is_dir():\n", - " if region_list.is_file():\n", - " region_list_df = pd.read_csv(region_list, sep='\\t', header=None, comment = \"#\")\n", - " region_ids = region_list_df.iloc[:, -1].unique() # Extracting the last column for IDs\n", - " else:\n", - " raise ValueError(\"The region_list path provided is not a file.\")\n", - " \n", - "if len(region_name) > 0:\n", - " region_ids = list(set(region_ids).union(set(region_name)))\n", - " \n", - "if len(region_ids) > 0:\n", - " xqtl_df = xqtl_df[xqtl_df['region_id'].isin(region_ids)]\n", - " \n", - "new_df = generate_condition_based_dataframe(xqtl_df, minp)\n", - "\n", - "# if there is only one original data file, we don't have to map to context meta\n", - "if (new_df['QTL_original_data'].str.split(',').apply(lambda x: len(x) in [0, 1]).all() and not context_meta.is_file()):\n", - " filtered_df = new_df.copy()\n", - " filtered_df['GWAS_original_data'] = filtered_df['GWAS_original_data'].apply(make_unique_data)\n", - "else:\n", - " filtered_df = merge_and_filter_dfs(new_df, generate_meta_dataframe(context_meta))\n", - "\n", - "filtered_df = prepare_final_paths(filtered_df, qtl_path, gwas_path)\n", - "filtered_df = filtered_df.groupby('condition').agg({\n", - " 'GWAS_original_data': lambda x: ','.join(x),\n", - " 'QTL_original_data': lambda x: ','.join(x)\n", - "}).reset_index()\n", - "regional_data = {\n", - " 'data': [row['QTL_original_data'].split(',') for _, row in filtered_df.iterrows()],\n", - " 'conditions': [(f\"{row['condition']}\", *row['GWAS_original_data'].split(',')) for _, row in filtered_df.iterrows()]\n", - "}" + "[get_analysis_regions: shared = {'enrichment_rows': \"list(__import__('csv').DictReader(open(enrichment_manifest), delimiter=chr(9)))\"}]\n", + "# Resolve the per-condition xQTL x GWAS enrichment units into a manifest TSV via\n", + "# enloc_manifest.R -- the coordinate-overlap pairing + per-condition study\n", + "# routing that the legacy get_analysis_regions did in-notebook with pandas. The\n", + "# parsed rows are shared as enrichment_rows, so [xqtl_gwas_enrichment]\n", + "# auto-triggers this step via depends: sos_variable -- the notebook is invoked\n", + "# exactly as before (e.g. sos run SuSiE_enloc.ipynb xqtl_gwas_enrichment).\n", + "input: None\n", + "enrichment_manifest = f\"{cwd:a}/get_analysis_regions/{name}.enrichment_manifest.tsv\"\n", + "bash: expand = \"${ }\", container = container\n", + " mkdir -p ${cwd:a}/get_analysis_regions\n", + " Rscript code/script/pecotmr_integration/enloc_manifest.R --mode enrichment \\\n", + " --xqtl-meta ${xqtl_meta_data} --gwas-meta ${gwas_meta_data} \\\n", + " ${(\"--context-meta \" + str(context_meta)) if context_meta.is_file() else \"\"} \\\n", + " ${(\"--qtl-path \" + str(qtl_path)) if qtl_path else \"\"} \\\n", + " ${(\"--gwas-path \" + str(gwas_path)) if gwas_path else \"\"} \\\n", + " ${(\"--region-list \" + str(region_list)) if region_list.is_file() else \"\"} \\\n", + " ${(\"--region-name \" + \",\".join(region_name)) if len(region_name) > 0 else \"\"} \\\n", + " ${(\"--gwas-finemapping-obj \" + \" \".join([str(x) for x in gwas_finemapping_obj])) if len(gwas_finemapping_obj) > 0 else \"\"} \\\n", + " ${\"--minp\" if minp else \"\"} \\\n", + " --output ${enrichment_manifest}" ] }, { @@ -487,71 +317,26 @@ }, "outputs": [], "source": [ - "# get overlapped regions from flatten table, to get the regions with overlapped variants and select those regions for coloc analysis\n", - "[get_overlapped_analysis_regions: shared = \"overlapped_regional_data\"]\n", - "import pandas as pd\n", - "def map_blocks_to_data(blocks, mapping_dict):\n", - " \"\"\"Map blocks to data using a provided mapping dictionary.\"\"\"\n", - " mapped_data = ','.join(mapping_dict.get(block.strip(), 'NA') for block in blocks.split(','))\n", - " return mapped_data\n", - "\n", - "def process_dataframes(xqtl_meta_data, gwas_meta_data):\n", - " \"\"\"Process the XQTL and GWAS dataframes.\"\"\"\n", - " xqtl_df = pd.read_csv(xqtl_meta_data, sep=\"\\t\")\n", - " # filter xQTL data with the ones have overlapped top loci variants with GWAS data\n", - " xqtl_df = xqtl_df[xqtl_df['block_top_loci'].notna()]\n", - "\n", - " gwas_df = pd.read_csv(gwas_meta_data, sep=\"\\t\") \n", - " gwas_df = gwas_df[gwas_df['conditions_top_loci'].notna()]\n", - " # e.g. gwas_finemapping_obj = ['AD_Bellenguez_2022', 'single_effect_regression', 'RSS_QC_RAISS_imputed']\n", - " # filter gwas data with find variants in specified cohort 'AD_Bellenguez_2022' and method 'RSS_QC_RAISS_imputed'\n", - " gwas_finemapping_obj_filtered = [obj for obj in gwas_finemapping_obj if obj != 'susie_result_trimmed' and obj != 'RSS_QC_RAISS_imputed']\n", - " if len(gwas_finemapping_obj_filtered) > 0:\n", - " pattern = '|'.join(gwas_finemapping_obj_filtered)\n", - " gwas_df = gwas_df[gwas_df['conditions_top_loci'].str.contains(pattern)]\n", - "\n", - " gwas_df = gwas_df[gwas_df['region_id'].isin(xqtl_df['block_top_loci'].str.split(',').explode().unique())]\n", - "\n", - " region_to_combined_data = dict(zip(gwas_df['region_id'], gwas_df['original_data']))\n", - " # and only consider the overlapped GWAS blocks\n", - " xqtl_df['block_data'] = xqtl_df['block_top_loci'].apply(map_blocks_to_data, args=(region_to_combined_data,))\n", - " xqtl_df['block_data'] = xqtl_df['block_data'].str.replace(',NA', '').str.replace('NA,', '')\n", - "\n", - " return xqtl_df, gwas_df\n", - "\n", - "xqtl_df, gwas_df = process_dataframes(xqtl_meta_data, gwas_meta_data)\n", - "\n", - "region_ids=[]\n", - "# If region_list is provided, read the file and extract IDs\n", - "if not region_list.is_dir():\n", - " if region_list.is_file():\n", - " region_list_df = pd.read_csv(region_list, sep='\\t', header=None, comment = \"#\")\n", - " region_ids = region_list_df.iloc[:, -1].unique() # Extracting the last column for IDs\n", - " else:\n", - " raise ValueError(\"The region_list path provided is not a file.\")\n", - " \n", - "if len(region_name) > 0:\n", - " region_ids = list(set(region_ids).union(set(region_name)))\n", - " \n", - "if len(region_ids) > 0:\n", - " xqtl_df = xqtl_df[xqtl_df['region_id'].isin(region_ids)]\n", - " \n", - " \n", - "new_df = generate_condition_based_dataframe(xqtl_df, minp)\n", - "\n", - "# if there is only one original data file, we don't have to map to context meta\n", - "if (new_df['QTL_original_data'].str.split(',').apply(lambda x: len(x) in [0, 1]).all() and not context_meta.is_file()):\n", - " filtered_df = new_df.copy()\n", - " filtered_df['GWAS_original_data'] = filtered_df['GWAS_original_data'].apply(make_unique_data)\n", - "else:\n", - " filtered_df = merge_and_filter_dfs(new_df, generate_meta_dataframe(context_meta))\n", - "\n", - "filtered_df = prepare_final_paths(filtered_df, qtl_path, gwas_path)\n", - "\n", - "overlapped_regional_data = {\n", - " 'data': [row['QTL_original_data'].split(',') for _, row in filtered_df.iterrows()],\n", - " 'conditions': [(f\"{row['condition']}@{row['region_id']}\", *row['GWAS_original_data'].split(',')) for _, row in filtered_df.iterrows()]\n", - "}\n" + "[get_overlapped_analysis_regions: shared = {'coloc_rows': \"list(__import__('csv').DictReader(open(coloc_manifest), delimiter=chr(9)))\"}]\n", + "# Resolve the per-(condition,region) xQTL x GWAS coloc units into a manifest TSV\n", + "# via enloc_manifest.R --mode coloc -- the block_top_loci variant-overlap pairing\n", + "# + per-condition study routing that the legacy get_overlapped_analysis_regions\n", + "# did in-notebook with pandas. Shared as coloc_rows, so [susie_coloc]\n", + "# auto-triggers this step (sos run SuSiE_enloc.ipynb susie_coloc) unchanged.\n", + "input: None\n", + "coloc_manifest = f\"{cwd:a}/get_overlapped_analysis_regions/{name}.coloc_manifest.tsv\"\n", + "bash: expand = \"${ }\", container = container\n", + " mkdir -p ${cwd:a}/get_overlapped_analysis_regions\n", + " Rscript code/script/pecotmr_integration/enloc_manifest.R --mode coloc \\\n", + " --xqtl-meta ${xqtl_meta_data} --gwas-meta ${gwas_meta_data} \\\n", + " ${(\"--context-meta \" + str(context_meta)) if context_meta.is_file() else \"\"} \\\n", + " ${(\"--qtl-path \" + str(qtl_path)) if qtl_path else \"\"} \\\n", + " ${(\"--gwas-path \" + str(gwas_path)) if gwas_path else \"\"} \\\n", + " ${(\"--region-list \" + str(region_list)) if region_list.is_file() else \"\"} \\\n", + " ${(\"--region-name \" + \",\".join(region_name)) if len(region_name) > 0 else \"\"} \\\n", + " ${(\"--gwas-finemapping-obj \" + \" \".join([str(x) for x in gwas_finemapping_obj])) if len(gwas_finemapping_obj) > 0 else \"\"} \\\n", + " ${\"--minp\" if minp else \"\"} \\\n", + " --output ${coloc_manifest}" ] }, { @@ -568,36 +353,21 @@ "outputs": [], "source": [ "[xqtl_gwas_enrichment]\n", - "depends: sos_variable(\"regional_data\")\n", - "stop_if(len(regional_data['data']) == 0, f'No files left for analysis')\n", - "\n", - "meta = regional_data['conditions']\n", - "input: regional_data[\"data\"], group_by = lambda x: group_by_region(x, regional_data[\"data\"]), group_with = \"meta\"\n", - "output: f'{cwd:a}/{name}.{_meta[0]}.enrichment.rds'\n", + "depends: sos_variable(\"enrichment_rows\")\n", + "jobs = enrichment_rows\n", + "stop_if(len(jobs) == 0, f'No files left for analysis')\n", + "_qtl_groups = [j['qtl_files'].split(',') for j in jobs]\n", + "input: [f for grp in _qtl_groups for f in grp], group_by = lambda x: _qtl_groups, group_with = \"jobs\"\n", + "output: f'{cwd:a}/{name}.{_jobs[\"unit_id\"]}.enrichment.rds'\n", "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", "bash: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container\n", " set -e\n", - " # Per-region xQTL files for this group, and the GWAS rds entries in _meta[1:].\n", - " # Convert each side of this region to a pecotmr S4 collection, then run\n", - " # qtlEnrichmentPipeline on the pair.\n", - " Rscript code/script/pecotmr_integration/legacy_enloc_finemap_convert.R \\\n", - " --mode qtl \\\n", - " --rds-files ${\",\".join([str(x) for x in _input])} \\\n", - " --finemapping-obj '${\" \".join(xqtl_finemapping_obj)}' \\\n", - " --varname-obj '${\" \".join(xqtl_varname_obj)}' \\\n", - " --study ${name} \\\n", - " --output ${_output:n}.qtl.rds\n", - "\n", - " Rscript code/script/pecotmr_integration/legacy_enloc_finemap_convert.R \\\n", - " --mode gwas \\\n", - " --rds-files ${\",\".join([str(x) for x in _meta[1:] if str(x).endswith(\".rds\")])} \\\n", - " --finemapping-obj '${\" \".join(gwas_finemapping_obj)}' \\\n", - " --varname-obj '${\" \".join(gwas_varname_obj)}' \\\n", - " --output ${_output:n}.gwas.rds\n", - "\n", + " # The xQTL and GWAS sides are already S4 FineMappingResult collections\n", + " # (fine_mapping output); qtl_enrichment.R combines its multi-file inputs\n", + " # itself, so the legacy legacy_enloc_finemap_convert.R step is gone.\n", " Rscript code/script/pecotmr_integration/qtl_enrichment.R \\\n", - " --qtl-fine-mapping ${_output:n}.qtl.rds \\\n", - " --gwas-fine-mapping ${_output:n}.gwas.rds \\\n", + " --qtl-fine-mapping ${\" \".join([str(x) for x in _input])} \\\n", + " --gwas-fine-mapping ${_jobs[\"gwas_files\"].replace(\",\", \" \")} \\\n", " --ncore ${numThreads} \\\n", " --output ${_output}\n" ] @@ -612,45 +382,30 @@ "outputs": [], "source": [ "[susie_coloc]\n", - "depends: sos_variable(\"overlapped_regional_data\")\n", + "depends: sos_variable(\"coloc_rows\")\n", "# depends: sos_step(\"xqtl_gwas_enrichment\") #changed\n", - "stop_if(len(overlapped_regional_data['data']) == 0, f'No files left for analysis')\n", + "stop_if(len(coloc_rows) == 0, f'No files left for analysis')\n", "# skip enrichment or not\n", "parameter: skip_enrich=False\n", "# filter lbf by cs as default in susie coloc. default is False means filtering by V > prior_tol\n", "parameter: filter_lbf_cs = False\n", "# ld reference path for postprocessing \n", "parameter: ld_meta_file_path = path()\n", - "meta = overlapped_regional_data['conditions']\n", - "input: overlapped_regional_data[\"data\"], group_by = lambda x: group_by_region(x, overlapped_regional_data[\"data\"]), group_with = \"meta\"\n", - "# output: f'{cwd:a}/{step_name[:-2]}/{name}.{_meta[0]}.coloc.rds'\n", - "output: f'{cwd:a}/{step_name}/{name}.{_meta[0]}.coloc.rds'\n", + "jobs = coloc_rows\n", + "_qtl_groups = [j['qtl_files'].split(',') for j in jobs]\n", + "input: [f for grp in _qtl_groups for f in grp], group_by = lambda x: _qtl_groups, group_with = \"jobs\"\n", + "output: f'{cwd:a}/{step_name}/{name}.{_jobs[\"unit_id\"]}.coloc.rds'\n", "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output:bn}'\n", "bash: expand = '${ }', stdout = f\"{_output:n}.stdout\", stderr = f\"{_output:n}.stderr\", container = container\n", " set -e\n", - " # context (before '@' in _meta[0]) selects the per-region enrichment file the\n", - " # enrichment step wrote: {cwd}/{name}.{context}.enrichment.rds (legacy naming).\n", - " # Convert this region's xQTL + GWAS sides, then run colocPipeline (enloc\n", - " # variant when --enrichment is supplied).\n", - " Rscript code/script/pecotmr_integration/legacy_enloc_finemap_convert.R \\\n", - " --mode qtl \\\n", - " --rds-files ${\",\".join([str(x) for x in _input])} \\\n", - " --finemapping-obj '${\" \".join(xqtl_finemapping_obj)}' \\\n", - " --varname-obj '${\" \".join(xqtl_varname_obj)}' \\\n", - " --study ${name} \\\n", - " --output ${_output:n}.qtl.rds\n", - "\n", - " Rscript code/script/pecotmr_integration/legacy_enloc_finemap_convert.R \\\n", - " --mode gwas \\\n", - " --rds-files ${\",\".join([str(x) for x in _meta[1:] if str(x).endswith(\".rds\")])} \\\n", - " --finemapping-obj '${\" \".join(gwas_finemapping_obj)}' \\\n", - " --varname-obj '${\" \".join(gwas_varname_obj)}' \\\n", - " --output ${_output:n}.gwas.rds\n", - "\n", + " # xQTL + GWAS sides are already S4 FineMappingResult collections; coloc.R\n", + " # combines its multi-file inputs itself (no legacy conversion). The enrichment\n", + " # file (context before '@' in unit_id) tunes colocPipeline's prior.\n", " Rscript code/script/pecotmr_integration/coloc.R \\\n", - " --qtl-fine-mapping ${_output:n}.qtl.rds \\\n", - " --gwas-input ${_output:n}.gwas.rds \\\n", - " ${('--enrichment '+cwd.absolute().joinpath(name + \".\" + _meta[0].split(\"@\")[0] + \".enrichment.rds\").as_posix()) if not skip_enrich else ''} \\\n", + " --qtl-fine-mapping ${\" \".join([str(x) for x in _input])} \\\n", + " --gwas-input ${_jobs[\"gwas_files\"].replace(\",\", \" \")} \\\n", + " ${('--filter-lbf-cs' if filter_lbf_cs else '')} \\\n", + " ${('--enrichment '+cwd.absolute().joinpath(name + \".\" + _jobs[\"unit_id\"].split(\"@\")[0] + \".enrichment.rds\").as_posix()) if not skip_enrich else ''} \\\n", " --output ${_output}\n" ] }, @@ -698,4 +453,4 @@ }, "nbformat": 4, "nbformat_minor": 5 -} \ No newline at end of file +} diff --git a/code/SoS/pecotmr_integration/ctwas.ipynb b/code/SoS/pecotmr_integration/ctwas.ipynb deleted file mode 100644 index 4a338241f..000000000 --- a/code/SoS/pecotmr_integration/ctwas.ipynb +++ /dev/null @@ -1,102 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "# cTWAS via the three-step pecotmr API\n\n## Description\n\nDrives a multi-LD-block cTWAS analysis through `pecotmr`'s split pipeline:\n\n- `[ctwas_1]` — `assembleCtwasInputs`: consume the per-region manifest, load each block's `GwasSumStats` + per-gene `TwasWeights` RDS files, produce the assembled ctwas inputs (`z_snp`, `weights`, `region_info`, `snp_map`, `LD_map`, LD/snpInfo loader closures).\n- `[ctwas_2]` — `estCtwasParam`: estimate the joint group prior + prior variance (`ctwas::est_param`). `--fallback-to-prefit` recovers from accurate-EM NaN divergence by re-running the prefit step only (mirrors the legacy ctwas_2 workaround).\n- `[ctwas_3]` — `screenCtwasRegions` + `finemapCtwasRegions`: screen regions and fine-map causal genes; optional `--param-override` RDS lets the caller substitute hand-tuned priors before screening.\n\nThe three steps chain via intermediate RDS files (`{name}.ctwas_inputs.rds`, `{name}.ctwas_est.rds`, `{name}.ctwas_finemap.rds`) so individual stages can be re-run independently.\n\n## Inputs\n\n- `--manifest` — per-region manifest TSV with columns:\n - `region_id` (unique string)\n - `gwas_sumstats_rds` (path to per-block `GwasSumStats` RDS from `gwas_sumstats_construct.R`)\n - `twas_weights_rds` (comma-separated per-gene `TwasWeights` RDS paths for that block; may be empty for SNP-only blocks)\n - `fine_mapping_result_rds` (optional, comma-separated)\n- Optional weight pre-filters (`--twas-weight-cutoff`, `--cs-min-cor`, `--min-pip-cutoff`, `--max-num-variants`).\n- Optional `--twas-z` precomputed TWAS-Z `GRanges` RDS (output of `twas.ipynb`).\n- Step 2 knobs: `--thin`, `--niter-prefit`, `--niter`, `--min-group-size`, `--min-p-single-effect`, `--fallback-to-prefit`.\n- Step 3 knobs: `--L`, `--no-filter-L`, `--min-nonsnp-pip`, `--param-override`.\n\n## Output\n\n- `{cwd}/{name}.ctwas_inputs.rds` (step 1)\n- `{cwd}/{name}.ctwas_est.rds` (step 2)\n- `{cwd}/{name}.ctwas_finemap.rds` (step 3; ctwas_sumstats-shape result)\n" - ] - }, - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "## Example\n\n```bash\nsos run pipeline/ctwas.ipynb ctwas_3 \\\n --cwd output --modular-script-dir /path/to/code/script \\\n --name protocol_example_twas_chr22 \\\n --manifest /tmp/gwas_smoke/ctwas_manifest_blessed.tsv \\\n --fallback-to-prefit \\\n --min-group-size 1\n```\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\nparameter: cwd = path('output')\nparameter: name = str\nparameter: manifest = path\n# --- step 1 (assemble) -----------------------------------------------\nparameter: method = ''\nparameter: twas_z = path('.')\nparameter: twas_weight_cutoff = 0.0\nparameter: cs_min_cor = 0.8\nparameter: min_pip_cutoff = 0.0\nparameter: max_num_variants = 'Inf'\n# --- step 2 (est_param) ----------------------------------------------\nparameter: thin = 0.1\nparameter: niter_prefit = 3\nparameter: niter = 30\nparameter: group_prior_var_structure = 'shared_type'\nparameter: min_group_size = 100\nparameter: min_p_single_effect = 0.8\nparameter: fallback_to_prefit = False\n# --- step 3 (screen + finemap) ---------------------------------------\nparameter: L = 5\nparameter: no_filter_L = False\nparameter: min_nonsnp_pip = 0.5\nparameter: param_override = path('.')\n# --- infrastructure --------------------------------------------------\nparameter: modular_script_dir = path('code/script')\nparameter: container = ''\nparameter: job_size = 1\nparameter: walltime = '1h'\nparameter: mem = '16G'\nparameter: numThreads = 1\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[ctwas_1 (assemble inputs)]\ninput: manifest\noutput: f\"{cwd}/{name}.ctwas_inputs.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\nbash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n Rscript ${modular_script_dir}/pecotmr_integration/ctwas_assemble.R \\\n --manifest ${_input} \\\n ${'--method ' + method if method else ''} \\\n ${'--twas-z ' + str(twas_z) if twas_z.is_file() else ''} \\\n --twas-weight-cutoff ${twas_weight_cutoff} \\\n --cs-min-cor ${cs_min_cor} \\\n --min-pip-cutoff ${min_pip_cutoff} \\\n --max-num-variants ${max_num_variants} \\\n --output ${_output}\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[ctwas_2 (estimate priors)]\noutput: f\"{cwd}/{name}.ctwas_est.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\nbash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n Rscript ${modular_script_dir}/pecotmr_integration/ctwas_est.R \\\n --inputs ${_input} \\\n --thin ${thin} \\\n --niter-prefit ${niter_prefit} \\\n --niter ${niter} \\\n --group-prior-var-structure ${group_prior_var_structure} \\\n --min-group-size ${min_group_size} \\\n --min-p-single-effect ${min_p_single_effect} \\\n ${'--fallback-to-prefit' if fallback_to_prefit else ''} \\\n --ncore ${numThreads} \\\n --output ${_output}\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[ctwas_3 (screen + finemap)]\noutput: f\"{cwd}/{name}.ctwas_finemap.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\nbash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n Rscript ${modular_script_dir}/pecotmr_integration/ctwas_finemap.R \\\n --est ${_input} \\\n ${'--param-override ' + str(param_override) if param_override.is_file() else ''} \\\n --L ${L} \\\n ${'--no-filter-L' if no_filter_L else ''} \\\n --min-nonsnp-pip ${min_nonsnp_pip} \\\n --ncore ${numThreads} \\\n --output ${_output}\n" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "nbconvert_exporter": "sos_notebook.converter.SoS_Exporter", - "pygments_lexer": "sos" - }, - "sos": { - "kernels": [ - [ - "Bash", - "bash", - "Bash", - "#E6EEFF", - "shell" - ], - [ - "SoS", - "sos", - "", - "", - "sos" - ] - ], - "version": "0.24.3" - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} diff --git a/code/SoS/pecotmr_integration/enloc.ipynb b/code/SoS/pecotmr_integration/enloc.ipynb deleted file mode 100644 index 26d58dcd3..000000000 --- a/code/SoS/pecotmr_integration/enloc.ipynb +++ /dev/null @@ -1,89 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "# xQTL–GWAS enrichment + colocalization\n\n## Description\n\nReplaces the legacy `SuSiE_enloc.ipynb` two-step `[xqtl_gwas_enrichment]` / `[susie_coloc]` flow with two thin SoS steps backed by the new pecotmr S4 API. Pairs an xQTL-side `QtlFineMappingResult` with a GWAS-side `GwasFineMappingResult` (or `GwasSumStats`) and runs the two pipelines back-to-back:\n\n- `[enrichment]` — `qtlEnrichmentPipeline(gwasFineMappingResult, qtlFineMappingResult, ...)` produces a per-(gwasStudy, qtlContext) enrichment data.frame.\n- `[coloc]` — `colocPipeline(qtlFineMappingResult, gwasInput, ..., enrichment = )` runs `coloc::coloc.bf_bf` per (QTL tuple, GWAS tuple, CS pair) with enrichment-scaled `p12` priors (the \"enloc\" variant). Pass `--skip-enrichment` to run plain coloc with the default p12.\n\nBecause the S4 FMR collections already encapsulate every (study, context, trait, method) tuple across regions, the workflow is two single-call steps — no per-gene fan-out, no Python overlap helpers, no manifest. Per-region fan-out (and the per-region coloc loop) lives inside `colocPipeline` itself.\n\n## Inputs\n\n- `--qtl-fine-mapping` — path to S4 `QtlFineMappingResult` RDS (output of `fine_mapping.ipynb` / `fineMappingPipeline`).\n- `--gwas-fine-mapping` — path to S4 `GwasFineMappingResult` RDS (also a `fineMappingPipeline` output). `colocPipeline` will also accept a `GwasSumStats` RDS and inline-fine-map it.\n- `--name` — identifier used in the output filenames.\n- Optional enrichment knobs (`--num-gwas`, `--pi-qtl`, `--lambda`, `--imp-n`).\n- Optional coloc knobs (`--p1`, `--p2`, `--p12`, `--p12-max`, `--filter-lbf-cs`, `--filter-lbf-cs-secondary`, `--no-adjust-pips`).\n- `--skip-enrichment` — skip step 1 and run coloc with the default p12 (the non-enloc variant).\n\n## Outputs\n\n- `{cwd}/{name}.enrichment.rds` — data.frame, one row per (gwasStudy, qtlContext) pair (omitted when `--skip-enrichment`).\n- `{cwd}/{name}.coloc.rds` — data.frame, one row per (QTL tuple, GWAS tuple, CS pair).\n" - ] - }, - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": "## Example\n\n```bash\nsos run pipeline/enloc.ipynb susie_enloc \\\n --cwd output --modular-script-dir /path/to/code/script \\\n --name protocol_example_enloc \\\n --qtl-fine-mapping output/fine_mapping/protocol_example.qtl_finemap.rds \\\n --gwas-fine-mapping output/fine_mapping/protocol_example.gwas_finemap.rds\n```\n" - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\nparameter: cwd = path('output')\nparameter: name = str\nparameter: qtl_fine_mapping = path\nparameter: gwas_fine_mapping = path\n# --- step 1 (enrichment) --------------------------------------------\nparameter: skip_enrichment = False\nparameter: num_gwas = -1.0 # negative → NULL pass-through\nparameter: pi_qtl = -1.0 # negative → NULL pass-through\nparameter: lambda_ = 1.0\nparameter: imp_n = 25\n# --- step 2 (coloc) -------------------------------------------------\nparameter: p1 = 1e-4\nparameter: p2 = 1e-4\nparameter: p12 = 5e-6\nparameter: p12_max = 1e-3\nparameter: filter_lbf_cs = False\nparameter: filter_lbf_cs_secondary = -1.0 # negative → NULL\nparameter: no_adjust_pips = False\nparameter: finemapping_methods = 'susie'\n# --- infrastructure -------------------------------------------------\nparameter: modular_script_dir = path('code/script')\nparameter: container = ''\nparameter: job_size = 1\nparameter: walltime = '30m'\nparameter: mem = '16G'\nparameter: numThreads = 1\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[susie_enloc_1 (enrichment)]\nstop_if(skip_enrichment, '--skip-enrichment set; skipping qtlEnrichmentPipeline.')\ninput: qtl_fine_mapping, gwas_fine_mapping\noutput: f\"{cwd}/{name}.enrichment.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\nbash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n Rscript ${modular_script_dir}/pecotmr_integration/qtl_enrichment.R \\\n --qtl-fine-mapping ${qtl_fine_mapping} \\\n --gwas-fine-mapping ${gwas_fine_mapping} \\\n ${'--num-gwas ' + str(num_gwas) if num_gwas >= 0 else ''} \\\n ${'--pi-qtl ' + str(pi_qtl) if pi_qtl >= 0 else ''} \\\n --lambda ${lambda_} \\\n --imp-n ${imp_n} \\\n --ncore ${numThreads} \\\n --output ${_output}\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[susie_enloc_2 (coloc)]\nenrich_path = f\"{cwd}/{name}.enrichment.rds\"\nenrich_arg = f\"--enrichment {enrich_path}\" if not skip_enrichment else ''\ninput: qtl_fine_mapping, gwas_fine_mapping\noutput: f\"{cwd}/{name}.coloc.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\nbash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n Rscript ${modular_script_dir}/pecotmr_integration/coloc.R \\\n --qtl-fine-mapping ${qtl_fine_mapping} \\\n --gwas-input ${gwas_fine_mapping} \\\n ${enrich_arg} \\\n ${'--filter-lbf-cs' if filter_lbf_cs else ''} \\\n ${'--filter-lbf-cs-secondary ' + str(filter_lbf_cs_secondary) if filter_lbf_cs_secondary >= 0 else ''} \\\n --p1 ${p1} \\\n --p2 ${p2} \\\n --p12 ${p12} \\\n --p12-max ${p12_max} \\\n ${'--no-adjust-pips' if no_adjust_pips else ''} \\\n --finemapping-methods ${finemapping_methods} \\\n --output ${_output}\n" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "nbconvert_exporter": "sos_notebook.converter.SoS_Exporter", - "pygments_lexer": "sos" - }, - "sos": { - "kernels": [ - [ - "Bash", - "bash", - "Bash", - "#E6EEFF", - "shell" - ], - [ - "SoS", - "sos", - "", - "", - "sos" - ] - ], - "version": "0.24.3" - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/SoS/pecotmr_integration/fine_mapping.ipynb b/code/SoS/pecotmr_integration/fine_mapping.ipynb deleted file mode 100644 index 9c25c57d1..000000000 --- a/code/SoS/pecotmr_integration/fine_mapping.ipynb +++ /dev/null @@ -1,97 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": "# SuSiE fine-mapping (QTL or GWAS)\n\n## Description\n\nTwo workflows, both backed by `pecotmr::fineMappingPipeline` (which dispatches on the S4 input class):\n\n- **`fine_mapping`** — per-gene / per-region fine-mapping over a pre-built `QtlDataset` RDS. Fan-out goes by `--genes` (list of trait IDs, gene mode) **or** `--regions` (list of `chr:start-end` strings, region mode); exactly one must be supplied. Each task loads the same QtlDataset RDS and fine-maps one unit.\n- **`fine_mapping_gwas`** — per-block fine-mapping over a list of per-block `GwasSumStats` RDS paths (typically produced by `gwas_sumstats_construct.R` / `gwas_sumstats.ipynb`). One task per RDS; each task produces one `GwasFineMappingResult` RDS. Downstream consumers (e.g. `enloc.ipynb`) concatenate the per-block outputs as needed.\n\n## Inputs\n\n### `fine_mapping` (QTL)\n\n- `--qtl-dataset` — path to the QtlDataset RDS produced by `qtl_dataset.ipynb`.\n- `--genes ID1 ID2 \u2026` **or** `--regions chr:start-end \u2026` — fan-out targets (mutually exclusive).\n- `--cis-window` — bp window around each gene's TSS (gene mode only). Default 1,000,000.\n- `--methods` — comma-separated fine-mapping method tokens. Default `susie`.\n- `--coverage` — SuSiE credible-set coverage. Default 0.95.\n\n### `fine_mapping_gwas` (GWAS)\n\n- `--gwas-sumstats-list S1.rds S2.rds \u2026` — per-block GwasSumStats RDS paths to fan out over.\n- `--methods` — comma-separated fine-mapping method tokens. Default `susie`.\n- `--coverage` — SuSiE credible-set coverage. Default 0.95.\n\n### Both\n\n- `--cwd` — output directory. Default `output`.\n- `--study` — study label used in the output filename.\n- `--modular-script-dir` — directory containing the per-task worker R scripts. Default `code/script`; override when SoS is invoked from a working directory that doesn't contain them.\n\n## Outputs\n\n- `fine_mapping`: `{cwd}/{study}.{gene|region}.finemap.rds` per fan-out unit (region strings are sanitised: `:` and `-` become `_`).\n- `fine_mapping_gwas`: `{cwd}/{study}.{bn-of-gwas-sumstats-rds}.gwas_finemap.rds` per input RDS.\n" - }, - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": "## Example\n\nQTL (per-gene):\n```bash\nsos run pipeline/fine_mapping.ipynb fine_mapping \\\n --cwd output \\\n --modular-script-dir /path/to/xqtl-protocol/code/script \\\n --study TEST_STUDY \\\n --qtl-dataset output/TEST_STUDY.qtl_dataset.rds \\\n --genes ENSG00000060237 ENSG00000234593\n```\n\nGWAS (per-block, list of GwasSumStats RDS):\n```bash\nsos run pipeline/fine_mapping.ipynb fine_mapping_gwas \\\n --cwd output \\\n --modular-script-dir /path/to/xqtl-protocol/code/script \\\n --study TEST_STUDY \\\n --gwas-sumstats-list output/TEST_STUDY.block1.gwas_sumstats.rds \\\n output/TEST_STUDY.block2.gwas_sumstats.rds\n```\n" - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": "[global]\nparameter: cwd = path('output')\nparameter: study = str\nparameter: modular_script_dir = path('code/script')\n# --- fine_mapping (QTL) ----------------------------------------------\nparameter: qtl_dataset = path('.')\nparameter: genes = []\nparameter: regions = []\nparameter: cis_window = 1000000\n# --- fine_mapping_gwas -----------------------------------------------\nparameter: gwas_sumstats_list = []\n# --- shared ----------------------------------------------------------\nparameter: methods = 'susie'\nparameter: coverage = 0.95\nparameter: container = ''\nparameter: job_size = 1\nparameter: walltime = '30m'\nparameter: mem = '8G'\nparameter: numThreads = 1\n" - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[fine_mapping]\n", - "if not qtl_dataset.is_file():\n", - " raise ValueError(\"fine_mapping requires --qtl-dataset to point at an existing QtlDataset RDS.\")\n", - "if bool(genes) == bool(regions):\n", - " raise ValueError(\"Specify exactly one of --genes (trait IDs) or --regions (chr:start-end strings).\")\n", - "fanout_items = genes if genes else regions\n", - "fanout_kind = 'gene' if genes else 'region'\n", - "input: qtl_dataset, for_each = 'fanout_items'\n", - "output: f\"{cwd}/{study}.{_fanout_items.replace(':', '_').replace('-', '_')}.finemap.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping.R \\\n", - " --qtl-dataset ${_input} \\\n", - " ${('--gene-id ' + _fanout_items + ' --cis-window ' + str(cis_window)) if fanout_kind == 'gene' else ('--region ' + _fanout_items)} \\\n", - " --methods ${methods} \\\n", - " --coverage ${coverage} \\\n", - " --output ${_output}\n" - ] - }, - { - "cell_type": "code", - "source": "[fine_mapping_gwas]\nif not gwas_sumstats_list:\n raise ValueError(\"fine_mapping_gwas requires --gwas-sumstats-list pointing at one or more per-block GwasSumStats RDS files.\")\ngss_paths = [str(p) for p in gwas_sumstats_list]\ninput: gss_paths, group_by = 1\noutput: f\"{cwd}/{study}.{_input:bnn}.gwas_finemap.rds\"\ntask: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\nbash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping.R \\\n --gwas-sumstats ${_input} \\\n --methods ${methods} \\\n --coverage ${coverage} \\\n --output ${_output}\n", - "metadata": {}, - "execution_count": null, - "outputs": [] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "nbconvert_exporter": "sos_notebook.converter.SoS_Exporter", - "pygments_lexer": "sos" - }, - "sos": { - "kernels": [ - [ - "Bash", - "bash", - "Bash", - "#E6EEFF", - "shell" - ], - [ - "SoS", - "sos", - "", - "", - "sos" - ] - ], - "version": "0.24.3" - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/SoS/pecotmr_integration/fine_mapping_postprocessing.ipynb b/code/SoS/pecotmr_integration/fine_mapping_postprocessing.ipynb deleted file mode 100644 index d0a6a4db4..000000000 --- a/code/SoS/pecotmr_integration/fine_mapping_postprocessing.ipynb +++ /dev/null @@ -1,248 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": {}, - "source": [ - "# Fine-mapping postprocessing\n", - "\n", - "## Description\n", - "\n", - "Postprocessing utilities for the S4 `QtlFineMappingResult` / `GwasFineMappingResult` RDSes produced by `fine_mapping.ipynb`, `multivariate_fine_mapping.ipynb`, `functional_fine_mapping.ipynb`, or `rss_analysis.ipynb`. Replaces the legacy `mnm_analysis/mnm_postprocessing.ipynb` (which consumed the older list-shaped RDS layout).\n", - "\n", - "All steps consume FMR RDSes through the pecotmr S4 accessor surface (`getPip`, `getCs`, `getTopLoci`, `getMarginalEffects`, `getVariantIds`) so they work uniformly for QTL and GWAS outputs.\n", - "\n", - "Workflow steps (all independent — pick what you need):\n", - "\n", - "- **`[export_top_loci]`** — concatenate every input RDS's top-loci table into one TSV (one row per variant, with `study / context / trait / region_id / method / source` identifier columns).\n", - "- **`[export_credible_sets]`** — same shape, but the per-row CS membership.\n", - "- **`[export_pip]`** — raw `variant_id / pip` long table across all inputs (filterable with `--signal-cutoff`).\n", - "- **`[export_marginals]`** — per-variant marginal effects (`beta / se / z / p`) across all inputs.\n", - "- **`[pip_landscape_plot]`** — per-RDS PIP-vs-position scatter, one facet per FMR row.\n", - "- **`[upset_cs_overlap]`** — UpSet plot of credible-set variant overlap across one or more RDSes (one set per `(study, context, trait, method)` tuple for QTL; per `(study, method, region_id)` for GWAS).\n", - "\n", - "## Inputs\n", - "\n", - "- `--fmr-list [ ...]` — one or more FineMappingResult RDS files (mix QTL and GWAS freely; identifier columns adapt per class).\n", - "- `--name` — output filename prefix.\n", - "- `--signal-cutoff` — PIP cutoff for `export_top_loci` / `export_pip`. Default 0 (no filter); pass 0.025 to mirror the legacy susie default.\n", - "- `--max-sets` — cap on UpSet set count (default 20).\n", - "- `--cwd` / `--modular-script-dir` — standard SoS infra.\n", - "\n", - "## Outputs\n", - "\n", - "Per-step:\n", - "\n", - "- `{cwd}/{name}.topLoci.tsv.gz`\n", - "- `{cwd}/{name}.cs.tsv.gz`\n", - "- `{cwd}/{name}.pip.tsv.gz`\n", - "- `{cwd}/{name}.marginals.tsv.gz`\n", - "- `{cwd}/plots/{name}.{rds-basename}.pip_landscape.png` (one per input RDS)\n", - "- `{cwd}/plots/{name}.upset.png`\n" - ] - }, - { - "cell_type": "markdown", - "metadata": {}, - "source": [ - "## Example\n", - "\n", - "```bash\n", - "# Top-loci TSV + UpSet plot across every fine-mapping RDS in a run:\n", - "sos run pipeline/fine_mapping_postprocessing.ipynb \\\n", - " export_top_loci+upset_cs_overlap \\\n", - " --cwd output/postprocessing \\\n", - " --modular-script-dir /path/to/code/script \\\n", - " --name myrun \\\n", - " --signal-cutoff 0.025 \\\n", - " --fmr-list output/fine_mapping/*.finemap.rds\n", - "\n", - "# All four TSV exports + per-RDS PIP plot:\n", - "sos run pipeline/fine_mapping_postprocessing.ipynb \\\n", - " export_top_loci+export_credible_sets+export_pip+export_marginals+pip_landscape_plot \\\n", - " --cwd output/postprocessing --name myrun \\\n", - " --fmr-list output/fine_mapping/*.finemap.rds\n", - "```\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\n", - "parameter: cwd = path('output')\n", - "parameter: modular_script_dir = path('code/script')\n", - "parameter: name = str\n", - "# One or more FineMappingResult RDS paths (mix QTL + GWAS freely).\n", - "parameter: fmr_list = []\n", - "parameter: signal_cutoff = 0.0\n", - "parameter: max_sets = 20\n", - "parameter: container = ''\n", - "parameter: job_size = 1\n", - "parameter: walltime = '30m'\n", - "parameter: mem = '8G'\n", - "parameter: numThreads = 1\n", - "\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[export_top_loci]\n", - "stop_if(not fmr_list, '--fmr-list requires at least one RDS path.')\n", - "paths = [str(p) for p in fmr_list]\n", - "input: paths\n", - "output: f\"{cwd}/{name}.topLoci.tsv.gz\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_export.R \\\n", - " --input ${_input} \\\n", - " --view topLoci \\\n", - " --signal-cutoff ${signal_cutoff} \\\n", - " --output ${_output}" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[export_credible_sets]\n", - "stop_if(not fmr_list, '--fmr-list requires at least one RDS path.')\n", - "paths = [str(p) for p in fmr_list]\n", - "input: paths\n", - "output: f\"{cwd}/{name}.cs.tsv.gz\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_export.R \\\n", - " --input ${_input} \\\n", - " --view cs \\\n", - " --output ${_output}" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[export_pip]\n", - "stop_if(not fmr_list, '--fmr-list requires at least one RDS path.')\n", - "paths = [str(p) for p in fmr_list]\n", - "input: paths\n", - "output: f\"{cwd}/{name}.pip.tsv.gz\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_export.R \\\n", - " --input ${_input} \\\n", - " --view pip \\\n", - " --signal-cutoff ${signal_cutoff} \\\n", - " --output ${_output}" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[export_marginals]\n", - "stop_if(not fmr_list, '--fmr-list requires at least one RDS path.')\n", - "paths = [str(p) for p in fmr_list]\n", - "input: paths\n", - "output: f\"{cwd}/{name}.marginals.tsv.gz\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_export.R \\\n", - " --input ${_input} \\\n", - " --view marginals \\\n", - " --output ${_output}" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[pip_landscape_plot]\n", - "stop_if(not fmr_list, '--fmr-list requires at least one RDS path.')\n", - "paths = [str(p) for p in fmr_list]\n", - "# One PNG per input RDS (per-row fan-out).\n", - "input: paths, group_by = 1\n", - "output: f\"{cwd}/plots/{name}.{_input:bn}.pip_landscape.png\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_pip_plot.R \\\n", - " --input ${_input} \\\n", - " --output ${_output}" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[upset_cs_overlap]\n", - "stop_if(not fmr_list, '--fmr-list requires at least one RDS path.')\n", - "paths = [str(p) for p in fmr_list]\n", - "input: paths\n", - "output: f\"{cwd}/plots/{name}.upset.png\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping_upset.R \\\n", - " --input ${_input} \\\n", - " --max-sets ${max_sets} \\\n", - " --output ${_output}" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "pygments_lexer": "python", - "sos": { - "kernels": [ - [ - "SoS", - "sos", - "", - "" - ] - ], - "version": "0.22.4" - } - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/SoS/pecotmr_integration/functional_fine_mapping.ipynb b/code/SoS/pecotmr_integration/functional_fine_mapping.ipynb deleted file mode 100644 index 31cf43349..000000000 --- a/code/SoS/pecotmr_integration/functional_fine_mapping.ipynb +++ /dev/null @@ -1,141 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": {}, - "source": [ - "# Functional fine-mapping (fSuSiE)\n", - "\n", - "## Description\n", - "\n", - "Per-region functional fine-mapping via `pecotmr::fineMappingPipeline(qtlDataset, methods = \"fsusie\")`. fSuSiE jointly fine-maps multiple correlated phenotypes (typically epigenomic bins within an LD block) in one region, producing one `QtlFineMappingResult` per fan-out unit. Each task loads the same `QtlDataset` RDS and fits one unit.\n", - "\n", - "This replaces the `[fsusie]` and `[mvfsusie]` steps of the legacy `mnm_regression.ipynb`. The same `fine_mapping.R` worker that drives univariate SuSiE drives fSuSiE here — only the `--methods` value differs.\n", - "\n", - "## Inputs\n", - "\n", - "- `--qtl-dataset` — path to the `QtlDataset` RDS produced by `qtl_dataset.ipynb`. Each context's phenotype matrix typically holds multiple correlated bins per region (e.g. epigenomic peaks); fSuSiE fits them jointly.\n", - "- `--regions chr:start-end ...` **or** `--genes ID1 ID2 ...` — fan-out targets (mutually exclusive). Region mode is the standard use.\n", - "- `--cis-window` — bp window (gene mode only). Default 1,000,000.\n", - "- `--methods` — comma-separated method tokens. Default `fsusie`.\n", - "- `--coverage` — credible-set coverage. Default 0.95.\n", - "- `--method-args` — optional JSON object spliced into `fineMappingPipeline()` for fSuSiE-specific knobs (e.g. `prior`, `max_SNP_EM`, `max_scale`, `min_purity`) and other pipeline knobs not exposed as flags.\n", - "- `--cwd` — output directory. Default `output`.\n", - "- `--study` — study label used in the output filename.\n", - "- `--modular-script-dir` — directory holding the per-task R workers. Default `code/script`.\n", - "\n", - "## Outputs\n", - "\n", - "- `{cwd}/{study}.{gene|region}.fn_finemap.rds` — one `QtlFineMappingResult` per fan-out unit. Region strings are sanitised (`:` and `-` become `_`).\n" - ] - }, - { - "cell_type": "markdown", - "metadata": {}, - "source": [ - "## Example\n", - "\n", - "Region mode (canonical, joint multi-bin):\n", - "```bash\n", - "sos run pipeline/functional_fine_mapping.ipynb functional_fine_mapping \\\n", - " --cwd output \\\n", - " --modular-script-dir /path/to/xqtl-protocol/code/script \\\n", - " --study TEST_STUDY \\\n", - " --qtl-dataset output/TEST_STUDY.qtl_dataset.rds \\\n", - " --regions chr7:139293693-145380632\n", - "```\n", - "\n", - "With fSuSiE prior + max-iter overrides:\n", - "```bash\n", - "sos run pipeline/functional_fine_mapping.ipynb functional_fine_mapping \\\n", - " --cwd output --study TEST_STUDY \\\n", - " --qtl-dataset output/TEST_STUDY.qtl_dataset.rds \\\n", - " --regions chr7:139293693-145380632 \\\n", - " --method-args '{\"signalCutoff\":0.01}'\n", - "```\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\n", - "parameter: cwd = path('output')\n", - "parameter: study = str\n", - "parameter: modular_script_dir = path('code/script')\n", - "parameter: qtl_dataset = path('.')\n", - "parameter: genes = []\n", - "parameter: regions = []\n", - "parameter: cis_window = 1000000\n", - "parameter: methods = 'fsusie'\n", - "parameter: coverage = 0.95\n", - "# JSON object spliced into fineMappingPipeline() via do.call. Empty disables.\n", - "parameter: method_args = ''\n", - "parameter: container = ''\n", - "parameter: job_size = 1\n", - "parameter: walltime = '1h'\n", - "parameter: mem = '16G'\n", - "parameter: numThreads = 1" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[functional_fine_mapping]\n", - "if not qtl_dataset.is_file():\n", - " raise ValueError(\"functional_fine_mapping requires --qtl-dataset to point at an existing QtlDataset RDS.\")\n", - "if bool(genes) == bool(regions):\n", - " raise ValueError(\"Specify exactly one of --genes (trait IDs) or --regions (chr:start-end strings).\")\n", - "fanout_items = genes if genes else regions\n", - "fanout_kind = 'gene' if genes else 'region'\n", - "input: qtl_dataset, for_each = 'fanout_items'\n", - "output: f\"{cwd}/{study}.{_fanout_items.replace(':', '_').replace('-', '_')}.fn_finemap.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping.R \\\n", - " --qtl-dataset ${_input} \\\n", - " ${('--gene-id ' + _fanout_items + ' --cis-window ' + str(cis_window)) if fanout_kind == 'gene' else ('--region ' + _fanout_items)} \\\n", - " --methods ${methods} \\\n", - " --coverage ${coverage} \\\n", - " ${('--method-args ' + repr(method_args)) if method_args else ''} \\\n", - " --output ${_output}" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "pygments_lexer": "python", - "sos": { - "kernels": [ - [ - "SoS", - "sos", - "", - "" - ] - ], - "version": "0.22.4" - } - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/SoS/pecotmr_integration/gwas_sumstats.ipynb b/code/SoS/pecotmr_integration/gwas_sumstats.ipynb deleted file mode 100644 index cc206ac65..000000000 --- a/code/SoS/pecotmr_integration/gwas_sumstats.ipynb +++ /dev/null @@ -1,126 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "# Per-LD-block GwasSumStats construction\n\n## Description\n\nFor one study's GWAS TSV, fan out per LD block, build a `pecotmr::GwasSumStats` (including `summaryStatsQc()`), and serialize one RDS per `(study, block)`. The RDS files become the per-block GWAS inputs for `twas.ipynb` and `ctwas.ipynb`.\n\n## Inputs\n\n- `--study` — study identifier.\n- `--gwas-tsv` — path to the GWAS summary-statistics TSV.\n- `--ld-blocks` — BED file of LD-block intervals (`chr/chrom`, `start`, `stop/end`).\n- `--ld-meta` — LD-meta TSV pointing at per-region LD references.\n- `--genome` — genome build label. Default `hg19`.\n- `--modular-script-dir` — directory containing the worker R scripts.\n\n## Output\n\n- `{cwd}/{study}.{block_id}.gwas_sumstats.rds` per LD block (`block_id` sanitises `:`\u2192`_`, `-`\u2192`_`).\n" - ] - }, - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "## Example\n\n```bash\nsos run pipeline/gwas_sumstats.ipynb gwas_sumstats_construct \\\n --cwd output --modular-script-dir /path/to/code/script \\\n --study TEST_GWAS \\\n --gwas-tsv input/twas/protocol_example.twas.gwas_sumstats.chr22.tsv.gz \\\n --ld-blocks input/twas/protocol_example.twas.LD_blocks.chr22.bed \\\n --ld-meta input/ld_reference/protocol_example.ld_meta_file.tsv\n```\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\n", - "parameter: cwd = path('output')\n", - "parameter: study = str\n", - "parameter: gwas_tsv = path\n", - "parameter: ld_blocks = path\n", - "parameter: ld_meta = path\n", - "parameter: genome = 'hg19'\n", - "parameter: modular_script_dir = path('code/script')\n", - "parameter: container = ''\n", - "parameter: walltime = '30m'\n", - "parameter: mem = '8G'\n", - "parameter: numThreads = 1" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[generate_manifest]\n", - "# Parse the LD-blocks BED into a (region, region_id) TSV manifest via\n", - "# ld_blocks_to_manifest.R. Downstream fans out over its rows; no Python\n", - "# parsing in this notebook.\n", - "input: ld_blocks\n", - "output: f\"{cwd}/{study}.blocks_manifest.tsv\"\n", - "task: trunk_workers = 1, trunk_size = 1, walltime = '15m', mem = '2G', cores = 1, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/ld_blocks_to_manifest.R \\\n", - " --ld-blocks ${_input} \\\n", - " --output ${_output}" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[gwas_sumstats_construct]\n", - "# Fan out over the manifest's rows: one GwasSumStats per LD block.\n", - "import csv\n", - "jobs = list(csv.DictReader(open(f\"{cwd}/{study}.blocks_manifest.tsv\"), delimiter='\\t'))\n", - "input: gwas_tsv, for_each = 'jobs'\n", - "output: f\"{cwd}/{study}.{_jobs['region_id']}.gwas_sumstats.rds\"\n", - "task: trunk_workers = 1, trunk_size = 1, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/gwas_sumstats_construct.R \\\n", - " --study ${study} \\\n", - " --gwas-tsv ${_input} \\\n", - " --ld-block ${_jobs['region']} \\\n", - " --ld-meta ${ld_meta} \\\n", - " --genome ${genome} \\\n", - " --output ${_output}" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "nbconvert_exporter": "sos_notebook.converter.SoS_Exporter", - "pygments_lexer": "sos" - }, - "sos": { - "kernels": [ - [ - "Bash", - "bash", - "Bash", - "#E6EEFF", - "shell" - ], - [ - "SoS", - "sos", - "", - "", - "sos" - ] - ], - "version": "0.24.3" - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/SoS/pecotmr_integration/multivariate_fine_mapping.ipynb b/code/SoS/pecotmr_integration/multivariate_fine_mapping.ipynb deleted file mode 100644 index 194261c51..000000000 --- a/code/SoS/pecotmr_integration/multivariate_fine_mapping.ipynb +++ /dev/null @@ -1,143 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": {}, - "source": [ - "# Multivariate fine-mapping (mvSuSiE)\n", - "\n", - "## Description\n", - "\n", - "Per-region multivariate fine-mapping via `pecotmr::fineMappingPipeline(qtlDataset, methods = \"mvsusie\")`. mvSuSiE jointly fine-maps across the QtlDataset's traits and contexts in one region, producing one `QtlFineMappingResult` per fan-out unit. Each task loads the same `QtlDataset` RDS and fits one unit.\n", - "\n", - "This replaces the `[mnm]` and `[mnm_genes]` steps of the legacy `mnm_regression.ipynb`. The same `fine_mapping.R` worker that drives univariate SuSiE drives mvSuSiE here \u2014 only the `--methods` value differs.\n", - "\n", - "For mvSuSiE TWAS weights (mr.mash + mvSuSiE), call `twas_weights.ipynb --methods mrmash,mvsusie` afterwards against the same `QtlDataset`.\n", - "\n", - "## Inputs\n", - "\n", - "- `--qtl-dataset` — path to the `QtlDataset` RDS produced by `qtl_dataset.ipynb`. Multi-context / multi-trait shape is what makes mvSuSiE meaningful.\n", - "- `--regions chr:start-end ...` **or** `--genes ID1 ID2 ...` — fan-out targets (mutually exclusive). Region mode (multi-trait joint) is the standard use; gene mode runs the multi-context mvSuSiE variant for one focal trait.\n", - "- `--cis-window` — bp window (gene mode only). Default 1,000,000.\n", - "- `--methods` — comma-separated method tokens. Default `mvsusie`. Pass e.g. `mvsusie,susie` to also run univariate SuSiE alongside.\n", - "- `--coverage` — SuSiE/mvSuSiE credible-set coverage. Default 0.95.\n", - "- `--method-args` — optional JSON object spliced into `fineMappingPipeline()` for knobs not exposed as flags (priors, max-iter, residual options, etc.).\n", - "- `--cwd` — output directory. Default `output`.\n", - "- `--study` — study label used in the output filename.\n", - "- `--modular-script-dir` — directory holding the per-task R workers. Default `code/script`.\n", - "\n", - "## Outputs\n", - "\n", - "- `{cwd}/{study}.{gene|region}.mv_finemap.rds` — one `QtlFineMappingResult` per fan-out unit. Region strings are sanitised (`:` and `-` become `_`).\n" - ] - }, - { - "cell_type": "markdown", - "metadata": {}, - "source": [ - "## Example\n", - "\n", - "Region mode (canonical, multi-trait joint):\n", - "```bash\n", - "sos run pipeline/multivariate_fine_mapping.ipynb multivariate_fine_mapping \\\n", - " --cwd output \\\n", - " --modular-script-dir /path/to/xqtl-protocol/code/script \\\n", - " --study TEST_STUDY \\\n", - " --qtl-dataset output/TEST_STUDY.qtl_dataset.rds \\\n", - " --regions chr12:752578-2752578\n", - "```\n", - "\n", - "With mixture-prior tuning passed through:\n", - "```bash\n", - "sos run pipeline/multivariate_fine_mapping.ipynb multivariate_fine_mapping \\\n", - " --cwd output --study TEST_STUDY \\\n", - " --qtl-dataset output/TEST_STUDY.qtl_dataset.rds \\\n", - " --regions chr12:752578-2752578 \\\n", - " --method-args '{\"addSusieInf\":false,\"signalCutoff\":0.01}'\n", - "```\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\n", - "parameter: cwd = path('output')\n", - "parameter: study = str\n", - "parameter: modular_script_dir = path('code/script')\n", - "parameter: qtl_dataset = path('.')\n", - "parameter: genes = []\n", - "parameter: regions = []\n", - "parameter: cis_window = 1000000\n", - "parameter: methods = 'mvsusie'\n", - "parameter: coverage = 0.95\n", - "# JSON object spliced into fineMappingPipeline() via do.call. Empty disables.\n", - "parameter: method_args = ''\n", - "parameter: container = ''\n", - "parameter: job_size = 1\n", - "parameter: walltime = '1h'\n", - "parameter: mem = '16G'\n", - "parameter: numThreads = 1" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[multivariate_fine_mapping]\n", - "if not qtl_dataset.is_file():\n", - " raise ValueError(\"multivariate_fine_mapping requires --qtl-dataset to point at an existing QtlDataset RDS.\")\n", - "if bool(genes) == bool(regions):\n", - " raise ValueError(\"Specify exactly one of --genes (trait IDs) or --regions (chr:start-end strings).\")\n", - "fanout_items = genes if genes else regions\n", - "fanout_kind = 'gene' if genes else 'region'\n", - "input: qtl_dataset, for_each = 'fanout_items'\n", - "output: f\"{cwd}/{study}.{_fanout_items.replace(':', '_').replace('-', '_')}.mv_finemap.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/fine_mapping.R \\\n", - " --qtl-dataset ${_input} \\\n", - " ${('--gene-id ' + _fanout_items + ' --cis-window ' + str(cis_window)) if fanout_kind == 'gene' else ('--region ' + _fanout_items)} \\\n", - " --methods ${methods} \\\n", - " --coverage ${coverage} \\\n", - " ${('--method-args ' + repr(method_args)) if method_args else ''} \\\n", - " --output ${_output}" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "pygments_lexer": "python", - "sos": { - "kernels": [ - [ - "SoS", - "sos", - "", - "" - ] - ], - "version": "0.22.4" - } - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/SoS/pecotmr_integration/qtl_dataset.ipynb b/code/SoS/pecotmr_integration/qtl_dataset.ipynb deleted file mode 100644 index 55e976ce8..000000000 --- a/code/SoS/pecotmr_integration/qtl_dataset.ipynb +++ /dev/null @@ -1,80 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "# Build a QtlDataset per study\n\n## Description\n\nConstruct a single pecotmr `QtlDataset` from one study's genotype + per-context phenotype + per-context covariate files (plus an optional uniform genotype-PC file), and serialize it to a single RDS. The resulting object is the upstream dependency for every per-gene fineMapping / TWAS / colocboost task \u2014 gene-level parallelization happens against this single object via per-gene `traitId` selectors inside the downstream pipelines.\n\nThis step does NOT iterate over genes or regions. Build the QtlDataset once per study; downstream notebooks fan out per-gene tasks against the resulting RDS.\n\n## Inputs\n\n- `--study` — study identifier.\n- `--genotype-prefix` — PLINK1 bed/bim/fam prefix (no extension).\n- `--phenotype-manifest` — TSV with columns `#chr, start, end, ID, path, cond` (and optionally `cov_path`). One row per (region, context). Relative `path` / `cov_path` entries resolve against the manifest's own directory.\n- `--genotype-covariates` — optional TSV of genotype-derived covariates (e.g. ancestry PCs) applied uniformly across all contexts.\n- `--transpose-covariates` — when set, transposes every covariate TSV (phenotype + genotype) after reading. Use this for QTLtools-format inputs where rows are covariate names and columns are samples.\n- `--maf-cutoff` / `--xvar-cutoff` — pass-through to `QtlDataset()`. Lazy filters applied inside the accessors at fit time.\n\n## Output\n\n- `{cwd}/{study}.qtl_dataset.rds`\n" - ] - }, - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "## Example\n\n```bash\nsos run pipeline/qtl_dataset.ipynb qtl_dataset_construct \\\n --cwd output \\\n --study TEST_STUDY \\\n --genotype-prefix input/colocboost/example.chr22 \\\n --phenotype-manifest input/colocboost/pheno_manifest_multicontext.tsv \\\n --transpose-covariates\n```\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\nparameter: cwd = path('output')\nparameter: study = str\nparameter: genotype_prefix = path\nparameter: phenotype_manifest = path\nparameter: genotype_covariates = path('.')\n# Set when covariate TSVs are in QTLtools format (rows = covariates, cols = samples).\nparameter: transpose_covariates = False\nparameter: maf_cutoff = 0.0\nparameter: xvar_cutoff = 0.0\n# Directory holding code/script of the xqtl-protocol checkout; override\n# when SoS is invoked from a working dir that doesn't contain the scripts.\nparameter: modular_script_dir = path('code/script')\nparameter: container = ''\nparameter: walltime = '15m'\nparameter: mem = '8G'\nparameter: numThreads = 1\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[qtl_dataset_construct]\n# Build the QtlDataset once. No fan-out; downstream notebooks load this\n# RDS and parallelize per gene.\noutput: f\"{cwd}/{study}.qtl_dataset.rds\"\ntask: trunk_workers = 1, trunk_size = 1, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\nbash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n Rscript ${modular_script_dir}/pecotmr_integration/qtl_dataset_construct.R \\\n --study ${study} \\\n --genotype-prefix ${genotype_prefix} \\\n --phenotype-manifest ${phenotype_manifest} \\\n --genotype-covariates ${genotype_covariates if genotype_covariates.is_file() else '\"\"'} \\\n ${'--transpose-covariates' if transpose_covariates else ''} \\\n --maf-cutoff ${maf_cutoff} \\\n --xvar-cutoff ${xvar_cutoff} \\\n --output ${_output}\n" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "nbconvert_exporter": "sos_notebook.converter.SoS_Exporter", - "pygments_lexer": "sos" - }, - "sos": { - "kernels": [ - [ - "Bash", - "bash", - "Bash", - "#E6EEFF", - "shell" - ], - [ - "SoS", - "sos", - "", - "", - "sos" - ] - ], - "version": "0.24.3" - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/SoS/pecotmr_integration/twas.ipynb b/code/SoS/pecotmr_integration/twas.ipynb deleted file mode 100644 index 34b16efe1..000000000 --- a/code/SoS/pecotmr_integration/twas.ipynb +++ /dev/null @@ -1,117 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "# Per-gene TWAS Z + Mendelian Randomization\n\n## Description\n\nFan out per row of a per-gene manifest. Each row pairs a gene's `TwasWeights` RDS with the matching `GwasSumStats` RDS for that gene's home LD block; the SoS step runs `twas.R` per row, which calls `pecotmr::causalInferencePipeline()` to compute the gene's TWAS Z + (optional) MR statistics. Optional per-gene `FineMappingResult` is wired through too.\n\n## Inputs\n\n- `--manifest` — per-gene manifest TSV with columns:\n - `gene_id` — gene identifier (unique; used in the output filename).\n - `twas_weights_rds` — path to the per-gene `TwasWeights` RDS (single TwasWeightsEntry).\n - `gwas_sumstats_rds` — path to the per-LD-block `GwasSumStats` RDS that covers the gene's home block.\n - `fine_mapping_result_rds` — optional; path to the matching per-gene `FineMappingResult` RDS (leave blank to skip).\n- `--study` — study identifier (used in output filenames).\n- `--mr-pip-cutoff` — pass-through (default 0.5).\n- `--mr-method` — pass-through (`\"ivwPerVariant\"` or `\"csAware\"`; default `\"ivwPerVariant\"`).\n\n## Output\n\n- `{cwd}/{study}.{gene_id}.twas.rds` per gene.\n" - ] - }, - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "## Example\n\n```bash\nsos run pipeline/twas.ipynb twas \\\n --cwd output --modular-script-dir /path/to/code/script \\\n --study protocol_example_chr22 \\\n --manifest /tmp/gwas_smoke/twas_manifest.tsv\n```\n\nManifest example:\n```\ngene_id\ttwas_weights_rds\tgwas_sumstats_rds\tfine_mapping_result_rds\nENSG00000130538\t/tmp/gwas_smoke/blessed_tw.rds\t/tmp/gwas_smoke/blocks/chr22_10516173_17414263.rds\t\n```\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\nparameter: cwd = path('output')\nparameter: study = str\nparameter: manifest = path\nparameter: mr_pip_cutoff = 0.5\nparameter: mr_method = 'ivwPerVariant'\nparameter: modular_script_dir = path('code/script')\nparameter: container = ''\nparameter: job_size = 1\nparameter: walltime = '30m'\nparameter: mem = '8G'\nparameter: numThreads = 1\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[validate_manifest]\n", - "# Validate + canonicalise the user-supplied per-gene TWAS manifest via\n", - "# twas_manifest_validate.R. Downstream fans out over its rows; no\n", - "# Python parsing in this notebook.\n", - "input: manifest\n", - "output: f\"{cwd}/{study}.twas_manifest.tsv\"\n", - "task: trunk_workers = 1, trunk_size = 1, walltime = '15m', mem = '2G', cores = 1, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/twas_manifest_validate.R \\\n", - " --manifest ${_input} \\\n", - " --output ${_output}" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[twas]\n", - "# Fan out over the canonical manifest's rows: one task per gene_id.\n", - "# Manifest columns: gene_id, twas_weights_rds, gwas_sumstats_rds, and\n", - "# optionally fine_mapping_result_rds.\n", - "import csv\n", - "jobs = list(csv.DictReader(open(f\"{cwd}/{study}.twas_manifest.tsv\"), delimiter='\\t'))\n", - "input: for_each = 'jobs'\n", - "output: f\"{cwd}/{study}.{_jobs['gene_id']}.twas.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/twas.R \\\n", - " --twas-weights ${_jobs['twas_weights_rds']} \\\n", - " --gwas-sumstats ${_jobs['gwas_sumstats_rds']} \\\n", - " ${('--fine-mapping-result ' + _jobs.get('fine_mapping_result_rds', '')) if _jobs.get('fine_mapping_result_rds') else ''} \\\n", - " --mr-pip-cutoff ${mr_pip_cutoff} \\\n", - " --mr-method ${mr_method} \\\n", - " --output ${_output}" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "nbconvert_exporter": "sos_notebook.converter.SoS_Exporter", - "pygments_lexer": "sos" - }, - "sos": { - "kernels": [ - [ - "Bash", - "bash", - "Bash", - "#E6EEFF", - "shell" - ], - [ - "SoS", - "sos", - "", - "", - "sos" - ] - ], - "version": "0.24.3" - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/SoS/pecotmr_integration/twas_ctwas.ipynb b/code/SoS/pecotmr_integration/twas_ctwas.ipynb index 10acc761b..08367701b 100644 --- a/code/SoS/pecotmr_integration/twas_ctwas.ipynb +++ b/code/SoS/pecotmr_integration/twas_ctwas.ipynb @@ -351,56 +351,7 @@ "parameter: name_suffix = \"\"\n", "# optional parameter in ctwas to only perform gwas specific analysis \n", "parameter: gwas_study=[]\n", - "\n", - "import os\n", - "import pandas as pd\n", - "\n", - "def adapt_file_path(file_path, reference_file):\n", - " \"\"\"\n", - " Adapt a single file path based on its existence and a reference file's path.\n", - "\n", - " Args:\n", - " - file_path (str): The file path to adapt.\n", - " - reference_file (str): File path to use as a reference for adaptation.\n", - "\n", - " Returns:\n", - " - str: Adapted file path.\n", - "\n", - " Raises:\n", - " - FileNotFoundError: If no valid file path is found.\n", - " \"\"\"\n", - " reference_path = os.path.dirname(reference_file)\n", - "\n", - " # Check if the file exists\n", - " if os.path.isfile(file_path):\n", - " return file_path\n", - "\n", - " # Check file name without path\n", - " file_name = os.path.basename(file_path)\n", - " if os.path.isfile(file_name):\n", - " return file_name\n", - "\n", - " # Check file name in reference file's directory\n", - " file_in_ref_dir = os.path.join(reference_path, file_name)\n", - " if os.path.isfile(file_in_ref_dir):\n", - " return file_in_ref_dir\n", - "\n", - " # Check original file path prefixed with reference file's directory\n", - " file_prefixed = os.path.join(reference_path, file_path)\n", - " if os.path.isfile(file_prefixed):\n", - " return file_prefixed\n", - "\n", - " # If all checks fail, raise an error\n", - " raise FileNotFoundError(f\"No valid path found for file: {file_path}\")\n", - "\n", - "def group_by_region(lst, partition):\n", - " # from itertools import accumulate\n", - " # partition = [len(x) for x in partition]\n", - " # Compute the cumulative sums once\n", - " # cumsum_vector = list(accumulate(partition))\n", - " # Use slicing based on the cumulative sums\n", - " # return [lst[(cumsum_vector[i-1] if i > 0 else 0):cumsum_vector[i]] for i in range(len(partition))]\n", - " return partition" + "\n" ] }, { @@ -414,156 +365,29 @@ }, "outputs": [], "source": [ - "[get_analysis_regions: shared = [\"filtered_region_info\", \"filtered_regional_xqtl_files\", \"regional_data\"]]\n", - "from collections import OrderedDict\n", - "\n", - "def check_required_columns(df, required_columns):\n", - " \"\"\"Check if the required columns are present in the dataframe.\"\"\"\n", - " missing_columns = [col for col in required_columns if col not in list(df.columns)]\n", - " if missing_columns:\n", - " raise ValueError(f\"Missing required columns: {', '.join(missing_columns)}\")\n", - "\n", - "def extract_regional_data(gwas_meta_data, xqtl_meta_data, regions, region_name, gwas_name, gwas_data, column_mapping):\n", - " \"\"\"\n", - " Extracts data from GWAS and xQTL metadata files and additional GWAS data provided. \n", - "\n", - " Args:\n", - " - gwas_meta_data (str): File path to the GWAS metadata file.\n", - " - xqtl_meta_data (str): File path to the xQTL weight metadata file.\n", - " - gwas_name (list): vector of GWAS study names.\n", - " - gwas_data (list): vector of GWAS data.\n", - " - column_mapping (list, optional): vector of column mapping files.\n", - "\n", - " Returns:\n", - " - Tuple of two dictionaries:\n", - " - GWAS Dictionary: Maps study IDs to a list containing chromosome number, \n", - " GWAS file path, and optional column mapping file path.\n", - " - xQTL Dictionary: Nested dictionary with region IDs as keys.\n", - "\n", - " Raises:\n", - " - FileNotFoundError: If any specified file path does not exist.\n", - " - ValueError: If required columns are missing in the input files or vector lengths mismatch.\n", - " \"\"\"\n", - " # Check vector lengths\n", - " if len(gwas_name) != len(gwas_data):\n", - " raise ValueError(\"gwas_name and gwas_data must be of equal length\")\n", - " \n", - " if len(column_mapping)>0 and len(column_mapping) != len(gwas_name):\n", - " raise ValueError(\"If column_mapping is provided, it must be of the same length as gwas_name and gwas_data\")\n", - "\n", - " # Required columns for each file type\n", - " required_gwas_columns = ['study_id', 'chrom', 'file_path']\n", - " required_xqtl_columns = ['region_id', '#chr', 'start', 'end', \"TSS\", 'original_data'] #region_id here is gene name\n", - " required_ld_columns = ['chr', 'start', 'stop']\n", - " \n", - " # Reading the GWAS metadata file\n", - " gwas_df = pd.read_csv(gwas_meta_data, sep=\"\\t\")\n", - " check_required_columns(gwas_df, required_gwas_columns)\n", - " gwas_dict = OrderedDict()\n", - " \n", - " # Reading LD regions info\n", - " # Initialize empty DataFrame for regions\n", - " regions_df = pd.DataFrame(columns=['chr', 'start', 'stop'])\n", - "\n", - " # Check if regions file exists and read it\n", - " if os.path.isfile(regions):\n", - " file_regions_df = pd.read_csv(regions, sep=\"\\t\", skipinitialspace=True)\n", - " file_regions_df.columns = [col.strip() for col in file_regions_df.columns] # Strip spaces from column names\n", - " file_regions_df['chr'] = file_regions_df['chr'].str.strip()\n", - " check_required_columns(file_regions_df, required_ld_columns)\n", - " regions_df = pd.concat([regions_df, file_regions_df])\n", - " # Process region_name if provided: \n", - " # fomat: region_name = [\"chr1_16103_2888443\", \"chr1_4320284_5853833\"]\n", - " if len(region_name) > 0:\n", - " # Split region_name entries into chr, start, and stop columns\n", - " extra_regions = [name.split(\"_\") for name in region_name]\n", - " extra_regions_df = pd.DataFrame(extra_regions, columns=['chr', 'start', 'stop'])\n", - " extra_regions_df['start'] = extra_regions_df['start'].astype(int)\n", - " extra_regions_df['stop'] = extra_regions_df['stop'].astype(int)\n", - " # Add extra regions to regions_df\n", - " regions_df = extra_regions_df\n", - " # Remove duplicates and reset index\n", - " regions_df = regions_df.drop_duplicates().reset_index(drop=True)\n", - " regions_dict = OrderedDict()\n", - "\n", - " # Reading the xQTL weight metadata file\n", - " xqtl_df = pd.read_csv(xqtl_meta_data, sep=\"\\t\")\n", - " check_required_columns(xqtl_df, required_xqtl_columns)\n", - " xqtl_dict = OrderedDict()\n", - "\n", - " # Process additional GWAS data from R vectors\n", - " for name, data, mapping in zip(gwas_name, gwas_data, column_mapping or [None]*len(gwas_name)):\n", - " gwas_dict[name] = {0: [data, mapping]}\n", - "\n", - " for _, row in gwas_df.iterrows():\n", - " file_path = row['file_path']\n", - " mapping_file = row.get('column_mapping_file')\n", - " \n", - " # Adjust paths if necessary\n", - " file_path = adapt_file_path(file_path, gwas_meta_data)\n", - " if mapping_file:\n", - " mapping_file = adapt_file_path(mapping_file, gwas_meta_data)\n", - "\n", - " # Create or update the entry for the study_id\n", - " if row['study_id'] not in gwas_dict:\n", - " gwas_dict[row['study_id']] = {}\n", - "\n", - " # Expand chrom 0 to chrom 1-22 or use the specified chrom\n", - " chrom_range = range(1, 23) if row['chrom'] == 0 else [row['chrom']]\n", - " for chrom in chrom_range:\n", - " if chrom in gwas_dict[row['study_id']]:\n", - " existing_entry = gwas_dict[row['study_id']][f'chr{chrom}']\n", - " raise ValueError(f\"Duplicate chromosome specification for study_id {row['study_id']}, chrom {chrom}. \"\n", - " f\"Conflicting entries: {existing_entry} and {[file_path, mapping_file]}\")\n", - " gwas_dict[row['study_id']][f'chr{chrom}'] = [file_path, mapping_file]\n", - " \n", - " for _, row in regions_df.iterrows():\n", - " LD_region_id = f\"{row['chr']}_{row['start']}_{row['stop']}\"\n", - " overlapping_xqtls = xqtl_df[(xqtl_df['#chr'] == row['chr']) & \n", - " (xqtl_df['TSS'] <= row['stop']) & \n", - " (xqtl_df['TSS'] >= (row['start']))]\n", - " file_paths = []\n", - " mapped_genes = []\n", - " # Collect file paths for xQTLs overlapping this region\n", - " for _, xqtl_row in overlapping_xqtls.iterrows():\n", - " original_data = xqtl_row['original_data']\n", - " file_list = original_data.split(',') if ',' in original_data else [original_data]\n", - " file_paths.extend([adapt_file_path(fp.strip(), xqtl_meta_data) for fp in file_list])\n", - " mapped_genes.extend([xqtl_row['region_id']] * len(file_list))\n", - "\n", - " # Store metadata and files in the dictionary\n", - " regions_dict[LD_region_id] = {\n", - " \"meta_info\": [row['chr'], row['start'], row['stop'], LD_region_id, mapped_genes],\n", - " \"files\": file_paths\n", - " }\n", - " \n", - " for _, row in xqtl_df.iterrows():\n", - " file_paths = [adapt_file_path(fp.strip(), xqtl_meta_data) for fp in row['original_data'].split(',')] # Splitting and stripping file paths\n", - " xqtl_dict[row['region_id']] = {\"meta_info\": [row['#chr'], row['start'], row['end'], row['region_id'], row['contexts']],\n", - " \"files\": file_paths}\n", - " return gwas_dict, xqtl_dict, regions_dict\n", - "\n", - "\n", - "gwas_dict, xqtl_dict, regions_dict = extract_regional_data(gwas_meta_data, xqtl_meta_data,regions,region_name,gwas_name, gwas_data, column_mapping)\n", - "regional_data = dict([(\"GWAS\", gwas_dict), (\"xQTL\", xqtl_dict), (\"Regions\", regions_dict)])\n", - "\n", - "\n", - "# get regions data \n", - "region_info = [x[\"meta_info\"] for x in regional_data['Regions'].values()]\n", - "regional_xqtl_files = [x[\"files\"] for x in regional_data['Regions'].values()]\n", - "\n", - "# Filter out empty xQTL file paths\n", - "filtered_region_info = []\n", - "filtered_regional_xqtl_files = []\n", - "skipped_regions =[]\n", - "\n", - "for region, files in zip(region_info, regional_xqtl_files):\n", - " if files:\n", - " filtered_region_info.append(region)\n", - " filtered_regional_xqtl_files.append(files)\n", - " else:\n", - " skipped_regions.append(region)\n", - "print(f\"Skipping {len(skipped_regions)} out of {len(regional_xqtl_files)} regions, no overlapping xQTL weights found. \")" + "[get_analysis_regions: shared = {'twas_manifest_rows': \"list(__import__('csv').DictReader(open(twas_manifest_file), delimiter=chr(9)))\"}]\n", + "# Resolve the per-region TWAS analysis units into a manifest TSV via\n", + "# twas_manifest.R -- the gene<->region TSS-overlap binning, GWAS study/chrom\n", + "# resolution, and meta-relative path adaptation that the legacy\n", + "# extract_regional_data did in-notebook with pandas. The parsed rows are shared\n", + "# as twas_manifest_rows, so [twas] / [ctwas] auto-trigger this step via\n", + "# depends: sos_variable -- the notebook is invoked exactly as before\n", + "# (e.g. sos run twas_ctwas.ipynb twas). Gene -> home-LD-block placement is NOT\n", + "# done here: pecotmr's assembleCtwasInputs places each gene into its block from\n", + "# the weight `region` provenance.\n", + "input: None\n", + "twas_manifest_file = f\"{cwd:a}/get_analysis_regions/{name}.twas_manifest.tsv\"\n", + "bash: expand = \"${ }\", container = container\n", + " mkdir -p ${cwd:a}/get_analysis_regions\n", + " Rscript code/script/pecotmr_integration/twas_manifest.R \\\n", + " --gwas-meta ${gwas_meta_data} \\\n", + " --xqtl-meta ${xqtl_meta_data} \\\n", + " ${(\"--regions \" + str(regions)) if regions.is_file() else \"\"} \\\n", + " ${(\"--region-name \" + \",\".join(region_name)) if len(region_name) > 0 else \"\"} \\\n", + " ${(\"--gwas-name \" + \" \".join([str(x) for x in gwas_name])) if len(gwas_name) > 0 else \"\"} \\\n", + " ${(\"--gwas-data \" + \" \".join([str(x) for x in gwas_data])) if len(gwas_data) > 0 else \"\"} \\\n", + " ${(\"--column-mapping \" + \" \".join([str(x) for x in column_mapping])) if len(column_mapping) > 0 else \"\"} \\\n", + " --output ${twas_manifest_file}" ] }, { @@ -582,11 +406,14 @@ "# inside. Per region it (1) builds one multi-study GwasSumStats over the region\n", "# via gwas_sumstats_construct.R (its LD sketch spans whatever LD-reference\n", "# blocks the region overlaps), then per gene (2) converts the legacy\n", - "# univariate_twas_weights.rds to a pecotmr TwasWeights via\n", - "# legacy_twas_weights_convert.R and (3) runs twas.R (causalInferencePipeline)\n", + "# per-gene S4 TwasWeights (from twas_weights.ipynb) and\n", + "# runs twas.R (causalInferencePipeline) on the per-gene S4 TwasWeights\n", "# to emit a per-gene .twas.rds. MR is deferred (no fine-mapping result is\n", "# passed), so only TWAS Z + p-value are produced.\n", - "depends: sos_variable(\"filtered_regional_xqtl_files\")\n", + "# Fan-out consumes the get_analysis_regions manifest via its shared\n", + "# twas_manifest_rows, which auto-triggers that step -- so this runs exactly as\n", + "# before, e.g. sos run twas_ctwas.ipynb twas.\n", + "depends: sos_variable('twas_manifest_rows')\n", "# Legacy CLI retained. Wired to the pecotmr selection knobs: rsq_cutoff,\n", "# rsq_pval_cutoff, rsq_option, rsq_pval_option (CV weight selection). MR is\n", "# deferred, so mr_pval_cutoff and the remaining legacy params are kept declared\n", @@ -605,23 +432,25 @@ "parameter: event_filter_rules = path()\n", "parameter: comment_string = \"NULL\"\n", "parameter: rename_column = False\n", - "stop_if(len(filtered_regional_xqtl_files) == 0,\n", + "jobs = twas_manifest_rows\n", + "stop_if(len(jobs) == 0,\n", " \"No regions with overlapping xQTL weights found; skipping TWAS step.\")\n", - "input: filtered_regional_xqtl_files, group_by = lambda x: group_by_region(x, filtered_regional_xqtl_files), group_with = \"filtered_region_info\"\n", - "output: [f'{cwd:a}/{step_name}/{name}.{_filtered_region_info[3]}.{gene}.twas.rds' for gene in sorted(set(_filtered_region_info[4]))]\n", + "_weight_groups = [j['weight_files'].split(',') for j in jobs]\n", + "input: [f for grp in _weight_groups for f in grp], group_by = lambda x: _weight_groups, group_with = \"jobs\"\n", + "output: [f'{cwd:a}/{step_name}/{name}.{_jobs[\"region_id\"]}.{gene}.twas.rds' for gene in sorted(set(_jobs[\"genes\"].split(',')))]\n", "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f'{step_name}_{_output[0]:bn}'\n", "bash: expand = '${ }', stdout = f\"{_output[0]:n}.stdout\", stderr = f\"{_output[0]:n}.stderr\", container = container\n", " set -e\n", " # SoS expands ${...}; bare $shellvars (no braces) are left for bash.\n", " outdir=${cwd:a}/${step_name}\n", " mkdir -p \"$outdir\"\n", - " region_id=${_filtered_region_info[3]}\n", - " ld_block=${_filtered_region_info[0]}:${_filtered_region_info[1]}-${_filtered_region_info[2]}\n", + " region_id=${_jobs[\"region_id\"]}\n", + " ld_block=${_jobs[\"chrom\"]}:${_jobs[\"start\"]}-${_jobs[\"stop\"]}\n", "\n", " # GWAS studies covering this region's chromosome (paths already resolved by\n", " # get_analysis_regions). studies and gwas_tsvs iterate the same dict order.\n", - " studies=\"${\",\".join([s for s in regional_data['GWAS'] if _filtered_region_info[0] in regional_data['GWAS'][s]])}\"\n", - " gwas_tsvs=\"${\",\".join([regional_data['GWAS'][s][_filtered_region_info[0]][0] for s in regional_data['GWAS'] if _filtered_region_info[0] in regional_data['GWAS'][s]])}\"\n", + " studies=\"${_jobs[\"gwas_studies\"]}\"\n", + " gwas_tsvs=\"${_jobs[\"gwas_files\"]}\"\n", "\n", " # (1) One multi-study GwasSumStats over the whole region.\n", " gss=\"$outdir/${name}.$region_id.gwas_sumstats.rds\"\n", @@ -633,26 +462,21 @@ " --output \"$gss\"\n", "\n", " # (2)+(3) Per unique gene in this region (first weight file per gene):\n", - " # convert legacy weights (+FMR for MR), then run TWAS-Z + MR. The expansion\n", + " # run TWAS-Z + MR on the per-gene S4 weights. The expansion\n", " # below emits a flat \"gene file gene file ...\" token list (first file per\n", " # gene); the loop consumes it two tokens at a time.\n", " n_files=${len(_input)}\n", - " n_genes=${len(set([str(g) for g in _filtered_region_info[4]]))}\n", + " n_genes=${len(set(_jobs[\"genes\"].split(\",\")))}\n", " if [ \"$n_files\" -ne \"$n_genes\" ]; then\n", " echo \"NOTE: $n_files weight file(s) across $n_genes gene(s) in region $region_id; using the first file per gene.\" >&2\n", " fi\n", - " set -- ${\" \".join([tok for i, (g, f) in enumerate(zip(_filtered_region_info[4], _input)) if str(g) not in [str(h) for h in _filtered_region_info[4][:i]] for tok in (str(g), str(f))])}\n", + " set -- ${\" \".join([tok for i, (g, f) in enumerate(zip(_jobs[\"genes\"].split(\",\"), _input)) if g not in _jobs[\"genes\"].split(\",\")[:i] for tok in (g, str(f))])}\n", " while [ \"$#\" -ge 2 ]; do\n", " gene=\"$1\"\n", " weight=\"$2\"\n", " shift 2\n", - " tw=\"$outdir/${name}.$region_id.$gene.twas_weights.rds\"\n", - " Rscript code/script/pecotmr_integration/legacy_twas_weights_convert.R \\\n", - " --legacy \"$weight\" \\\n", - " --study \"${name}\" \\\n", - " --output \"$tw\"\n", " Rscript code/script/pecotmr_integration/twas.R \\\n", - " --twas-weights \"$tw\" \\\n", + " --twas-weights \"$weight\" \\\n", " --gwas-sumstats \"$gss\" \\\n", " --rsq-cutoff ${rsq_cutoff} \\\n", " --rsq-pval-cutoff ${rsq_pval_cutoff} \\\n", @@ -678,13 +502,16 @@ "# cTWAS step 1 (assemble): build the per-LD-block inputs for one gene-bearing\n", "# chromosome and assemble them via the pecotmr S4 wrappers (no inline analysis\n", "# R; no Python helpers). Per chromosome: (1) ctwas_manifest.R enumerates the\n", - "# chromosome's LD blocks from ld_meta_data, maps each gene (by TSS in\n", - "# xqtl_meta_data) to its home block, and pairs each block with a per-block\n", - "# GwasSumStats path + the gene's TwasWeights; (2) gwas_sumstats_construct.R\n", + "# chromosome's LD blocks from ld_meta_data (just the block grid; pecotmr places\n", + "# each gene into its home block from the weight `region` provenance);\n", + "# (2) gwas_sumstats_construct.R\n", "# builds one GwasSumStats per block (SNP background); (3) ctwas_assemble.R runs\n", "# assembleCtwasInputs -> {name}.ctwas_inputs.rds. cTWAS runs over the whole\n", "# chromosome's LD blocks, NOT the coarse twas analysis region.\n", - "depends: sos_variable(\"filtered_region_info\")\n", + "# Fan-in consumes the get_analysis_regions manifest via its shared\n", + "# twas_manifest_rows, which auto-triggers that step -- so this runs exactly as\n", + "# before, e.g. sos run twas_ctwas.ipynb ctwas.\n", + "depends: sos_variable('twas_manifest_rows')\n", "# chromosome to assemble (integer or 'chrN'); default: the lone gene-bearing chrom\n", "parameter: chrom = \"\"\n", "# weight pre-filters passed to assembleCtwasInputs\n", @@ -701,14 +528,17 @@ "# TwasWeights source (option c): empty -> the upstream twas step's per-gene\n", "# weights ({cwd}/twas/{name}.{region}.{gene}.twas_weights.rds); override with a\n", "# list of prebuilt TwasWeights RDS (e.g. the blessed ctwas weights extracted by\n", - "# legacy_ctwas_weights_to_s4.R) when the toy twas weights carry no signal.\n", + "# the blessed S4 ctwas weights) when the toy twas weights carry no signal.\n", "parameter: twas_weights = []\n", "skip_if(skip_assembly == True, \"Skip [ctwas_1] assemble.\")\n", - "gene_chroms = sorted(set(str(ri[0]) for ri in filtered_region_info if ri[4]))\n", + "jobs = twas_manifest_rows\n", + "gene_chroms = sorted(set(j[\"chrom\"] for j in jobs if j[\"genes\"]))\n", "ctwas_chrom = (f\"chr{int(chrom)}\" if str(chrom).isdigit() else str(chrom)) if str(chrom) else (gene_chroms[0] if len(gene_chroms) == 1 else \"\")\n", "stop_if(not ctwas_chrom, f\"Specify --chrom: expected one gene-bearing chromosome, found {gene_chroms}.\")\n", - "ctwas_weights = list(twas_weights) if twas_weights else [f\"{cwd:a}/twas/{name}.{ri[3]}.{g}.twas_weights.rds\" for ri in filtered_region_info if str(ri[0]) == ctwas_chrom for g in sorted(set(ri[4]))]\n", - "ctwas_studies = [s for s in regional_data['GWAS'] if ctwas_chrom in regional_data['GWAS'][s]]\n", + "ctwas_weights = list(twas_weights) if twas_weights else [f\"{cwd:a}/twas/{name}.{j['region_id']}.{g}.twas_weights.rds\" for j in jobs if j[\"chrom\"] == ctwas_chrom for g in sorted(set(j[\"genes\"].split(',')))]\n", + "_chrom_jobs = [j for j in jobs if j[\"chrom\"] == ctwas_chrom]\n", + "ctwas_studies = _chrom_jobs[0][\"gwas_studies\"].split(',') if _chrom_jobs and _chrom_jobs[0][\"gwas_studies\"] else []\n", + "ctwas_gwas_files = _chrom_jobs[0][\"gwas_files\"] if _chrom_jobs else \"\"\n", "stop_if(len(ctwas_studies) == 0, f\"No GWAS study covers {ctwas_chrom}.\")\n", "output: f\"{cwd:a}/ctwas/{name}.ctwas_inputs.rds\"\n", "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", @@ -718,19 +548,17 @@ " mkdir -p \"$outdir\"\n", " manifest=\"$outdir/${name}.ctwas_manifest.${ctwas_chrom}.tsv\"\n", "\n", - " # (1) per-LD-block manifest (block enumeration + gene->home-block mapping).\n", + " # (1) enumerate the chromosome's LD-block grid (block enumeration only).\n", " Rscript code/script/pecotmr_integration/ctwas_manifest.R \\\n", " --ld-meta \"${ld_meta_data}\" \\\n", " --chrom \"${ctwas_chrom}\" \\\n", - " --xqtl-meta \"${xqtl_meta_data}\" \\\n", - " --twas-weights \"${\",\".join([str(w) for w in ctwas_weights])}\" \\\n", " --gwas-sumstats-dir \"$outdir\" \\\n", " --output \"$manifest\"\n", "\n", " # (2) one GwasSumStats per LD block (all studies on this chromosome).\n", " studies=\"${\",\".join(ctwas_studies)}\"\n", - " gwas_tsvs=\"${\",\".join([regional_data['GWAS'][s][ctwas_chrom][0] for s in ctwas_studies])}\"\n", - " tail -n +2 \"$manifest\" | while IFS=$'\\t' read -r region_id region gwas_rds twas_w; do\n", + " gwas_tsvs=\"${ctwas_gwas_files}\"\n", + " tail -n +2 \"$manifest\" | while IFS=$'\\t' read -r region_id region gwas_rds; do\n", " Rscript code/script/pecotmr_integration/gwas_sumstats_construct.R \\\n", " --study \"$studies\" \\\n", " --gwas-tsv \"$gwas_tsvs\" \\\n", @@ -739,9 +567,10 @@ " --output \"$gwas_rds\"\n", " done\n", "\n", - " # (3) assemble cTWAS inputs.\n", + " # (3) assemble cTWAS inputs (pecotmr places each gene into its home block).\n", " Rscript code/script/pecotmr_integration/ctwas_assemble.R \\\n", " --manifest \"$manifest\" \\\n", + " --twas-weights \"${\",\".join([str(w) for w in ctwas_weights])}\" \\\n", " --twas-weight-cutoff ${twas_weight_cutoff} \\\n", " --cs-min-cor ${cs_min_cor} \\\n", " --min-pip-cutoff ${min_pip_cutoff} \\\n", @@ -818,6 +647,9 @@ "# region.\n", "parameter: merge_regions = False\n", "parameter: maxSNP = 20000\n", + "# retain the SNP background as a dedicated study=context=\"SNP\" CtwasResult row;\n", + "# default True matches the legacy pipeline, which kept SNP rows in the finemap output\n", + "parameter: keep_snps = True\n", "# declared for CLI stability; not consumed by the S4 path\n", "parameter: thin = 1.0\n", "parameter: max_iter = 0\n", @@ -839,6 +671,7 @@ " --L ${L} \\\n", " --min-nonsnp-pip ${min_nonSNP_PIP} \\\n", " ${('--merge-regions --merge-filter-cs --max-snp ' + str(maxSNP)) if merge_regions else ''} \\\n", + " ${'--keep-snps' if keep_snps else ''} \\\n", " --ncore ${numThreads} \\\n", " --output ${_output}" ] @@ -1038,4 +871,4 @@ }, "nbformat": 4, "nbformat_minor": 4 -} \ No newline at end of file +} diff --git a/code/SoS/pecotmr_integration/twas_weights.ipynb b/code/SoS/pecotmr_integration/twas_weights.ipynb deleted file mode 100644 index d9eb49908..000000000 --- a/code/SoS/pecotmr_integration/twas_weights.ipynb +++ /dev/null @@ -1,93 +0,0 @@ -{ - "cells": [ - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "# Per-gene / per-region TWAS weights against a pre-built QtlDataset\n\n## Description\n\nFor a single study's `QtlDataset` RDS, run `pecotmr::twasWeightsPipeline(methods = \"default\", ...)` per fan-out unit (gene or region). The default method preset gives the standard univariate methods (SuSiE / lasso / elastic-net / etc. as defined by `pecotmr::.twasMethodLookup(\"default\")`).\n\nOptionally pass a pre-fit `--fine-mapping-result` RDS; SuSiE-family TWAS methods reuse those fits via the `fineMappingResult` cache.\n\n## Inputs\n\n- `--qtl-dataset` — path to the QtlDataset RDS produced by `qtl_dataset.ipynb`.\n- `--genes ID1 ID2 \u2026` **or** `--regions chr:start-end \u2026` (mutually exclusive).\n- `--cis-window` — bp window (gene mode). Default 1,000,000.\n- `--fine-mapping-result` — optional pre-fit FineMappingResult RDS.\n- `--modular-script-dir` — directory containing the per-gene worker R scripts. Default `code/script`.\n\n## Output\n\n- `{cwd}/{study}.{gene|region}.twas_weights.rds` per fan-out unit.\n" - ] - }, - { - "cell_type": "markdown", - "metadata": { - "kernel": "SoS" - }, - "source": [ - "## Example\n\n```bash\nsos run pipeline/twas_weights.ipynb twas_weights \\\n --cwd output \\\n --modular-script-dir /path/to/xqtl-protocol/code/script \\\n --study TEST_STUDY \\\n --qtl-dataset output/TEST_STUDY.qtl_dataset.rds \\\n --genes ENSG00000060237 ENSG00000234593\n```\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[global]\nparameter: cwd = path('output')\nparameter: study = str\nparameter: qtl_dataset = path\nparameter: modular_script_dir = path('code/script')\n# Mutually exclusive fan-out sources: pass one as a list, leave the other empty.\nparameter: genes = []\nparameter: regions = []\nparameter: cis_window = 1000000\nparameter: fine_mapping_result = path('.')\nparameter: container = ''\nparameter: job_size = 1\nparameter: walltime = '30m'\nparameter: mem = '8G'\nparameter: numThreads = 1\n" - ] - }, - { - "cell_type": "code", - "execution_count": null, - "metadata": { - "kernel": "SoS" - }, - "outputs": [], - "source": [ - "[twas_weights]\n", - "if bool(genes) == bool(regions):\n", - " raise ValueError(\"Specify exactly one of --genes (trait IDs) or --regions (chr:start-end strings).\")\n", - "fanout_items = genes if genes else regions\n", - "fanout_kind = 'gene' if genes else 'region'\n", - "input: qtl_dataset, for_each = 'fanout_items'\n", - "output: f\"{cwd}/{study}.{_fanout_items.replace(':', '_').replace('-', '_')}.twas_weights.rds\"\n", - "task: trunk_workers = 1, trunk_size = job_size, walltime = walltime, mem = mem, cores = numThreads, tags = f\"{step_name}_{_output:bn}\"\n", - "bash: expand = '${ }', stderr = f\"{_output}.stderr\", stdout = f\"{_output}.stdout\", container = container\n", - " Rscript ${modular_script_dir}/pecotmr_integration/twas_weights.R \\\n", - " --qtl-dataset ${_input} \\\n", - " ${('--gene-id ' + _fanout_items + ' --cis-window ' + str(cis_window)) if fanout_kind == 'gene' else ('--region ' + _fanout_items)} \\\n", - " --fine-mapping-result ${fine_mapping_result if fine_mapping_result.is_file() else '\"\"'} \\\n", - " --output ${_output}\n" - ] - } - ], - "metadata": { - "kernelspec": { - "display_name": "SoS", - "language": "sos", - "name": "sos" - }, - "language_info": { - "codemirror_mode": "sos", - "file_extension": ".sos", - "mimetype": "text/x-sos", - "name": "sos", - "nbconvert_exporter": "sos_notebook.converter.SoS_Exporter", - "pygments_lexer": "sos" - }, - "sos": { - "kernels": [ - [ - "Bash", - "bash", - "Bash", - "#E6EEFF", - "shell" - ], - [ - "SoS", - "sos", - "", - "", - "sos" - ] - ], - "version": "0.24.3" - } - }, - "nbformat": 4, - "nbformat_minor": 4 -} \ No newline at end of file diff --git a/code/script/pecotmr_integration/ld_blocks_to_manifest.R b/code/script/graveyard/ld_blocks_to_manifest.R similarity index 93% rename from code/script/pecotmr_integration/ld_blocks_to_manifest.R rename to code/script/graveyard/ld_blocks_to_manifest.R index efe5b788e..34319667c 100644 --- a/code/script/pecotmr_integration/ld_blocks_to_manifest.R +++ b/code/script/graveyard/ld_blocks_to_manifest.R @@ -24,6 +24,9 @@ parser <- add_argument(parser, "--output", type = "character") argv <- parse_args(parser) +.d <- dirname(sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +source(file.path(.d, "manifest_common.R")) + if (!file.exists(argv$ld_blocks)) stop("--ld-blocks file not found: ", argv$ld_blocks) @@ -63,8 +66,6 @@ if (length(rows) == 0L) stop("No data rows parsed from --ld-blocks ", argv$ld_blocks) out <- do.call(rbind, rows) -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -write.table(out, file = argv$output, sep = "\t", quote = FALSE, - row.names = FALSE, na = "") +writeManifest(out, argv$output) cat(sprintf("Wrote LD-block manifest with %d row(s) to %s\n", nrow(out), argv$output)) diff --git a/code/script/pecotmr_integration/legacy_mash_input_to_sumstatslist.R b/code/script/graveyard/legacy_mash_input_to_sumstatslist.R similarity index 100% rename from code/script/pecotmr_integration/legacy_mash_input_to_sumstatslist.R rename to code/script/graveyard/legacy_mash_input_to_sumstatslist.R diff --git a/code/script/pecotmr_integration/legacy_sumstats_db_to_mash.R b/code/script/graveyard/legacy_sumstats_db_to_mash.R similarity index 100% rename from code/script/pecotmr_integration/legacy_sumstats_db_to_mash.R rename to code/script/graveyard/legacy_sumstats_db_to_mash.R diff --git a/code/script/pecotmr_integration/legacy_twas_weights_to_s4.R b/code/script/graveyard/legacy_twas_weights_to_s4.R similarity index 100% rename from code/script/pecotmr_integration/legacy_twas_weights_to_s4.R rename to code/script/graveyard/legacy_twas_weights_to_s4.R diff --git a/code/script/pecotmr_integration/mash_manifest.R b/code/script/graveyard/mash_manifest.R similarity index 96% rename from code/script/pecotmr_integration/mash_manifest.R rename to code/script/graveyard/mash_manifest.R index 6850b28d3..b6cd5be9d 100644 --- a/code/script/pecotmr_integration/mash_manifest.R +++ b/code/script/graveyard/mash_manifest.R @@ -41,6 +41,9 @@ parser <- add_argument(parser, "--output", type = "character") argv <- parse_args(parser) +.d <- dirname(sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +source(file.path(.d, "manifest_common.R")) + if (!file.exists(argv$region_file)) stop("--region-file not found: ", argv$region_file) sumFiles <- as.character(argv$sum_files) @@ -115,8 +118,6 @@ for (i in seq_len(nrow(regions))) { stringsAsFactors = FALSE) } out <- do.call(rbind, rows) -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -write.table(out, file = argv$output, sep = "\t", quote = FALSE, - row.names = FALSE, na = "") +writeManifest(out, argv$output) cat(sprintf("Wrote MASH manifest with %d row(s) (%d regions x %d conditions) to %s\n", nrow(out), nrow(regions), length(conditions), argv$output)) diff --git a/code/script/pecotmr_integration/twas_manifest_validate.R b/code/script/graveyard/twas_manifest_validate.R similarity index 100% rename from code/script/pecotmr_integration/twas_manifest_validate.R rename to code/script/graveyard/twas_manifest_validate.R diff --git a/code/script/pecotmr_integration/univariate_plot.R b/code/script/graveyard/univariate_plot.R similarity index 100% rename from code/script/pecotmr_integration/univariate_plot.R rename to code/script/graveyard/univariate_plot.R diff --git a/code/script/pecotmr_integration/univariate_rss.R b/code/script/graveyard/univariate_rss.R similarity index 100% rename from code/script/pecotmr_integration/univariate_rss.R rename to code/script/graveyard/univariate_rss.R diff --git a/code/script/pecotmr_integration/coloc.R b/code/script/pecotmr_integration/coloc.R index 55aebc7cf..febd9385a 100644 --- a/code/script/pecotmr_integration/coloc.R +++ b/code/script/pecotmr_integration/coloc.R @@ -33,11 +33,11 @@ suppressPackageStartupMessages({ parser <- arg_parser("Colocalization via colocPipeline()") parser <- add_argument(parser, "--qtl-fine-mapping", - help = "Path to S4 QtlFineMappingResult RDS", - type = "character") + help = "Path(s) to S4 QtlFineMappingResult RDS (combined if >1)", + type = "character", nargs = Inf) parser <- add_argument(parser, "--gwas-input", - help = "Path to S4 GwasFineMappingResult OR GwasSumStats RDS", - type = "character") + help = "Path(s) to S4 GwasFineMappingResult (combined if >1) OR one GwasSumStats RDS", + type = "character", nargs = Inf) parser <- add_argument(parser, "--enrichment", help = "Optional enrichment data.frame RDS (from qtl_enrichment.R)", type = "character", default = "") @@ -69,8 +69,22 @@ parser <- add_argument(parser, "--output", help = "Output RDS path", type = "character") argv <- parse_args(parser) -qtlFmr <- readRDS(argv$qtl_fine_mapping) -gwasIn <- readRDS(argv$gwas_input) +# Load one-or-more RDS(es) and combine FineMappingResults (the modern pipeline +# supplies per-study/per-block FMRs directly, replacing the legacy converter's +# multi --rds-files combine). A single non-FMR input (e.g. GwasSumStats) is used +# as supplied. +.loadCombine <- function(paths) { + objs <- lapply(as.character(paths), readRDS) + if (length(objs) == 1L) return(objs[[1L]]) + if (all(vapply(objs, function(o) methods::is(o, "FineMappingResultBase"), logical(1)))) { + # Preserve the (shared) ldSketch; combineFineMappingResults defaults it NULL. + ld <- tryCatch(objs[[1L]]@ldSketch, error = function(e) NULL) + return(do.call(combineFineMappingResults, c(objs, list(ldSketch = ld)))) + } + objs[[1L]] +} +qtlFmr <- .loadCombine(argv$qtl_fine_mapping) +gwasIn <- .loadCombine(argv$gwas_input) enrich <- if (nzchar(argv$enrichment) && argv$enrichment != "." && file.exists(argv$enrichment)) readRDS(argv$enrichment) else NULL diff --git a/code/script/pecotmr_integration/colocboost.R b/code/script/pecotmr_integration/colocboost.R index 23c1a8da3..987b448b1 100644 --- a/code/script/pecotmr_integration/colocboost.R +++ b/code/script/pecotmr_integration/colocboost.R @@ -42,8 +42,6 @@ suppressPackageStartupMessages({ library(argparser) library(pecotmr) - library(GenomicRanges) - library(IRanges) }) parser <- arg_parser("Per-gene or per-region colocboost over a pre-built QtlDataset") @@ -92,15 +90,6 @@ parse_pip_cutoff <- function(s) { } pip_cutoff_to_skip <- parse_pip_cutoff(argv$pip_cutoff_to_skip) -parse_region <- function(s) { - m <- regmatches(s, regexec("^([^:]+):([0-9]+)-([0-9]+)$", s))[[1L]] - if (length(m) != 4L) - stop("--region must be in chr:start-end format (got: ", s, ")") - GRanges(seqnames = m[[2L]], - ranges = IRanges(start = as.integer(m[[3L]]), - end = as.integer(m[[4L]]))) -} - # Mode validation has_gene <- nzchar(argv$gene_id) has_region <- nzchar(argv$region) @@ -128,7 +117,7 @@ res <- if (has_region) { colocboostPipeline( qd, gwasSumStats = gss, - region = parse_region(argv$region), + region = asGranges(argv$region), cisWindow = argv$cis_window, xqtlColoc = xqtl_coloc, jointGwas = joint_gwas, diff --git a/code/script/pecotmr_integration/colocboost_manifest.R b/code/script/pecotmr_integration/colocboost_manifest.R index 4357a2b6d..ce1f69290 100644 --- a/code/script/pecotmr_integration/colocboost_manifest.R +++ b/code/script/pecotmr_integration/colocboost_manifest.R @@ -77,27 +77,21 @@ parser <- add_argument(parser, "--output", help = "Output manifest TSV path", type = "character") argv <- parse_args(parser) +.d <- dirname(sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +source(file.path(.d, "manifest_common.R")) + # ----- Small helpers -------------------------------------------------------- -norm_chr <- function(x) { - x <- as.character(x) - ifelse(is.na(x) | !nzchar(x), x, - ifelse(startsWith(x, "chr"), x, paste0("chr", x))) -} resolve_against <- function(p, dir) { if (is.na(p) || !nzchar(p)) return("") if (startsWith(p, "/")) return(p) file.path(dir, p) } -read_tsv <- function(path) { - read.table(path, header = TRUE, sep = "\t", stringsAsFactors = FALSE, - check.names = FALSE, comment.char = "") -} # ----- Gene coordinates from the phenotype manifest ------------------------- if (is.null(argv$pheno_manifest) || !nzchar(argv$pheno_manifest) || !file.exists(argv$pheno_manifest)) stop("--pheno-manifest is required and must exist: ", argv$pheno_manifest) -pm <- read_tsv(argv$pheno_manifest) +pm <- readMeta(argv$pheno_manifest) id_col <- intersect(c("ID", "gene_id", "phenotype_id"), names(pm))[1L] chr_col <- intersect(c("#chr", "chrom", "chr"), names(pm))[1L] start_col <- intersect(c("start", "Start"), names(pm))[1L] @@ -107,7 +101,7 @@ if (any(is.na(c(id_col, chr_col, start_col, end_col)))) paste(names(pm), collapse = ", "), ").") genes <- as.character(pm[[id_col]]) -gchr <- norm_chr(pm[[chr_col]]) +gchr <- chromAdd(pm[[chr_col]]) gstart <- suppressWarnings(as.integer(pm[[start_col]])) gend <- suppressWarnings(as.integer(pm[[end_col]])) uniqGenes <- unique(genes) @@ -124,12 +118,11 @@ custom <- list() if (nzchar(argv$customized_association_windows) && argv$customized_association_windows != "." && file.exists(argv$customized_association_windows)) { - caw <- read.table(argv$customized_association_windows, header = FALSE, - sep = "", stringsAsFactors = FALSE, comment.char = "#") + caw <- readTableNoHeader(argv$customized_association_windows) # columns: chr start end ID for (i in seq_len(nrow(caw))) { g <- as.character(caw[[4L]][[i]]) - custom[[g]] <- list(chr = norm_chr(caw[[1L]][[i]]), + custom[[g]] <- list(chr = chromAdd(caw[[1L]][[i]]), start = as.integer(caw[[2L]][[i]]), end = as.integer(caw[[3L]][[i]])) } @@ -175,7 +168,7 @@ gene_window <- function(g) { gwasRows <- list() if (nzchar(argv$gwas_meta) && argv$gwas_meta != "." && file.exists(argv$gwas_meta)) { - gm <- read_tsv(argv$gwas_meta) + gm <- readMeta(argv$gwas_meta) req <- c("study_id", "chrom", "file_path") miss <- setdiff(req, names(gm)) if (length(miss) > 0L) @@ -202,7 +195,7 @@ if (nzchar(argv$gwas_meta) && argv$gwas_meta != "." && default_ld <- if (nzchar(argv$ld_meta) && argv$ld_meta != ".") argv$ld_meta else "" studies_for_chr <- function(chr) { - Filter(function(r) r$chrom == "0" || norm_chr(r$chrom) == chr, gwasRows) + Filter(function(r) r$chrom == "0" || chromAdd(r$chrom) == chr, gwasRows) } # ----- Build the per-gene manifest ------------------------------------------ @@ -241,9 +234,7 @@ if (length(rows) == 0L) "phenotype manifest.") out <- do.call(rbind, rows) -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -write.table(out, file = argv$output, sep = "\t", quote = FALSE, - row.names = FALSE, na = "") +writeManifest(out, argv$output) nWithGwas <- sum(nzchar(out$studies)) cat(sprintf("Wrote colocboost manifest with %d gene(s) (%d with GWAS) to %s\n", nrow(out), nWithGwas, argv$output)) diff --git a/code/script/pecotmr_integration/ctwas_assemble.R b/code/script/pecotmr_integration/ctwas_assemble.R index 747238b18..af7572e95 100644 --- a/code/script/pecotmr_integration/ctwas_assemble.R +++ b/code/script/pecotmr_integration/ctwas_assemble.R @@ -1,22 +1,32 @@ #!/usr/bin/env Rscript # ctwas_assemble.R # -# cTWAS step 1: per-region manifest → assembled cTWAS inputs. -# Reads the per-region manifest, loads each block's GwasSumStats / -# TwasWeights RDS, and calls pecotmr::assembleCtwasInputs() to build -# the named list of ctwas-shape inputs (z_snp, weights, region_info, -# snp_map, LD_map, LD/snpInfo loader closures). The result is saved -# to a single RDS that ctwas_est.R consumes downstream. +# cTWAS step 1: LD-block grid + flat weights -> assembled cTWAS inputs. +# Reads the block-grid manifest, loads each block's GwasSumStats RDS, loads the +# FLAT set of per-gene weight RDS, and calls pecotmr::assembleCtwasInputs(), +# which places each gene into its home LD block internally from the `region` +# provenance (matching cTWAS's p0 rule) and builds the ctwas-shape input set +# (z_snp, weights, region_info, snp_map, LD_map, LD/snpInfo loader closures). +# The result is saved to a single RDS that ctwas_est.R consumes downstream. +# +# The weights are NO LONGER bucketed per block in the manifest: they are handed +# in flat and placed by pecotmr. The weight source may be TwasWeights or +# QtlFineMappingResult objects (the latter uses each gene's topLoci posterior +# effect as its weight). # # Inputs: -# --manifest Per-region manifest TSV with columns: -# region_id (string, unique) -# gwas_sumstats_rds (per-block GwasSumStats RDS) -# twas_weights_rds (comma-sep per-gene TwasWeights RDS; may be empty) -# fine_mapping_result_rds (optional, comma-sep) +# --manifest Block-grid manifest TSV with columns: +# region_id (string, unique) +# gwas_sumstats_rds (per-block GwasSumStats RDS) +# --twas-weights Comma-separated FLAT per-gene weight RDS +# (TwasWeights or QtlFineMappingResult; each carries +# `region` provenance for placement) +# --fine-mapping-results Optional comma-separated FineMappingResult RDS used +# only as the CS / PIP rescue-filter source +# (NOT the weight source) # --method Which TWAS method to feed into ctwas -# (default: NULL — resolves to 'ensemble' if -# present, or sole method, or errors) +# (default: NULL — resolves to 'ensemble' if present, +# or the sole method, or errors) # --twas-z Optional TWAS-Z GRanges RDS # --twas-weight-cutoff Pass-through (default 0) # --cs-min-cor Pass-through (default 0.8) @@ -27,13 +37,18 @@ suppressPackageStartupMessages({ library(argparser) library(pecotmr) - library(S4Vectors) }) -parser <- arg_parser("cTWAS step 1: assemble inputs from per-region manifest") +parser <- arg_parser("cTWAS step 1: assemble inputs from block grid + flat weights") parser <- add_argument(parser, "--manifest", - help = "Per-region manifest TSV (region_id, gwas_sumstats_rds, twas_weights_rds[, fine_mapping_result_rds])", + help = "Block-grid manifest TSV (region_id, gwas_sumstats_rds)", + type = "character") +parser <- add_argument(parser, "--twas-weights", + help = "Comma-separated FLAT per-gene weight RDS (TwasWeights or QtlFineMappingResult)", type = "character") +parser <- add_argument(parser, "--fine-mapping-results", + help = "Optional comma-separated FineMappingResult RDS (CS/PIP filter source)", + type = "character", default = "") parser <- add_argument(parser, "--method", help = "Which TWAS method to feed into ctwas (defaults to 'ensemble' if present, or sole method)", type = "character", default = "") @@ -65,64 +80,47 @@ split_paths <- function(s) { manifest <- read.table(argv$manifest, header = TRUE, sep = "\t", stringsAsFactors = FALSE, check.names = FALSE, comment.char = "") -required <- c("region_id", "gwas_sumstats_rds", "twas_weights_rds") +required <- c("region_id", "gwas_sumstats_rds") missing <- setdiff(required, names(manifest)) if (length(missing) > 0L) - stop("Manifest missing required column(s): ", - paste(missing, collapse = ", ")) + stop("Manifest missing required column(s): ", paste(missing, collapse = ", ")) if (anyDuplicated(manifest$region_id)) stop("Manifest has duplicate region_id values.") if (nrow(manifest) < 2L) stop("Manifest must list at least two LD blocks. cTWAS's EM cannot ", "converge on a single region.") +# Per-block GWAS sum-stats keyed by region_id (the LD-block grid). gwasSumStatsByRegion <- list() -twasWeightsByRegion <- list() -fmrByRegion <- list() for (i in seq_len(nrow(manifest))) { rid <- manifest$region_id[[i]] gwasSumStatsByRegion[[rid]] <- readRDS(manifest$gwas_sumstats_rds[[i]]) - tw_paths <- split_paths(manifest$twas_weights_rds[[i]]) - if (length(tw_paths) > 0L) { - tw_list <- lapply(tw_paths, readRDS) - twasWeightsByRegion[[rid]] <- if (length(tw_list) == 1L) tw_list[[1L]] - else Reduce(function(a, b) - pecotmr:::.rbindTwasWeights(a, b), - tw_list) - } - if ("fine_mapping_result_rds" %in% names(manifest)) { - fmr_paths <- split_paths(manifest$fine_mapping_result_rds[[i]]) - if (length(fmr_paths) > 0L) { - fmr_list <- lapply(fmr_paths, readRDS) - fmrByRegion[[rid]] <- if (length(fmr_list) == 1L) fmr_list[[1L]] - else Reduce(function(a, b) - pecotmr:::.rbindFineMappingResult(a, b), - fmr_list) - } - } } -if (length(twasWeightsByRegion) == 0L) - stop("Manifest yielded zero TwasWeights across all blocks.") -# Optional precomputed TWAS-Z and fineMappingResult (single-object). +# FLAT weight source: an unnamed list of per-gene weight objects. assembleCtwasInputs +# combines them and places each gene into its home block by `region`. +weightPaths <- split_paths(argv$twas_weights) +if (length(weightPaths) == 0L) + stop("--twas-weights lists no weight RDS paths.") +weightObjs <- lapply(weightPaths, readRDS) + +# Optional precomputed TWAS-Z and the CS/PIP-filter FineMappingResult. tz <- if (nzchar(argv$twas_z) && argv$twas_z != "." && file.exists(argv$twas_z)) readRDS(argv$twas_z) else NULL -fmr <- if (length(fmrByRegion) > 0L) { - if (length(fmrByRegion) == 1L) fmrByRegion[[1L]] - else Reduce(function(a, b) pecotmr:::.rbindFineMappingResult(a, b), - unname(fmrByRegion)) -} else NULL +fmrPaths <- split_paths(argv$fine_mapping_results) +fmr <- if (length(fmrPaths) > 0L) + combineFineMappingResults(lapply(fmrPaths, readRDS)) else NULL inputs <- assembleCtwasInputs( - gwasSumStats = gwasSumStatsByRegion, - twasWeights = twasWeightsByRegion, - twasZ = tz, + gwasSumStats = gwasSumStatsByRegion, + twasWeights = weightObjs, + twasZ = tz, fineMappingResult = fmr, - method = if (nzchar(argv$method)) argv$method else NULL, - twasWeightCutoff = argv$twas_weight_cutoff, - csMinCor = argv$cs_min_cor, - minPipCutoff = argv$min_pip_cutoff, - maxNumVariants = argv$max_num_variants) + method = if (nzchar(argv$method)) argv$method else NULL, + twasWeightCutoff = argv$twas_weight_cutoff, + csMinCor = argv$cs_min_cor, + minPipCutoff = argv$min_pip_cutoff, + maxNumVariants = argv$max_num_variants) dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) saveRDS(inputs, argv$output) diff --git a/code/script/pecotmr_integration/ctwas_finemap.R b/code/script/pecotmr_integration/ctwas_finemap.R index 1eb95bc39..74390bbda 100644 --- a/code/script/pecotmr_integration/ctwas_finemap.R +++ b/code/script/pecotmr_integration/ctwas_finemap.R @@ -25,8 +25,12 @@ # --merge-filter-cs Flag: require a boundary gene to be in a credible # set to be selected for merging # --max-snp Per-merged-region SNP cap (default Inf) +# --keep-snps Flag: retain the SNP background as a dedicated +# study=context="SNP" row in the CtwasResult # --ncore Pass-through (default 1) -# --output Output RDS path (ctwas_sumstats-shape result) +# --output Output RDS path (a CtwasResult: one row per +# (gwasStudy, study, context, method), carrying the +# per-gene fine-mapping posteriors + susie alphas) suppressPackageStartupMessages({ library(argparser) @@ -61,6 +65,9 @@ parser <- add_argument(parser, "--merge-filter-cs", parser <- add_argument(parser, "--max-snp", help = "Per-merged-region SNP cap", type = "numeric", default = Inf) +parser <- add_argument(parser, "--keep-snps", + help = "Flag: retain the SNP background as a dedicated CtwasResult row", + flag = TRUE) parser <- add_argument(parser, "--ncore", help = "Number of cores", type = "integer", default = 1L) @@ -106,14 +113,19 @@ if (argv$merge_regions) { cat("Applied boundary-region merging (merge_regions).\n") } +# Structure the granular result as a CtwasResult (one row per +# (gwasStudy, study, context, method); GWAS study read from z_snp, method from +# the gene ids). This is the per-method deliverable downstream consumes. +result <- asCtwasResult(final, keepSnps = argv$keep_snps) + dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -saveRDS(final, argv$output) -cat(sprintf("Wrote finemapCtwasRegions result to %s\n", argv$output)) -fm <- final$finemap_res +saveRDS(result, argv$output) +cat(sprintf("Wrote CtwasResult (%d row(s)) to %s\n", nrow(result), argv$output)) +fm <- getFinemap(result) if (!is.null(fm) && nrow(fm) > 0L) { g <- fm[fm$type != "SNP", , drop = FALSE] - cat(sprintf(" finemap_res rows: %d (%d gene-level, %d SNP-level)\n", + cat(sprintf(" fine-mapped rows: %d (%d gene-level, %d SNP-level)\n", nrow(fm), nrow(g), nrow(fm) - nrow(g))) } else { - cat(" finemap_res: NULL (no regions surviving filter_L >= 1)\n") + cat(" no fine-mapped genes (no regions surviving filter_L >= 1)\n") } diff --git a/code/script/pecotmr_integration/ctwas_manifest.R b/code/script/pecotmr_integration/ctwas_manifest.R index 4a7a0dd1a..e844bcdc1 100644 --- a/code/script/pecotmr_integration/ctwas_manifest.R +++ b/code/script/pecotmr_integration/ctwas_manifest.R @@ -1,118 +1,62 @@ #!/usr/bin/env Rscript # ctwas_manifest.R # -# Build the per-LD-block manifest consumed by ctwas_assemble.R. cTWAS runs -# over the whole-chromosome LD-block grid (every LD-reference block is a SNP -# background "region"; only a few carry gene weights), so this worker: +# Enumerate the LD-block grid cTWAS runs over. cTWAS models the whole set of +# LD-reference blocks jointly (every block is a SNP-background "region"; only a +# few carry gene weights), so this worker simply lists the blocks — one row per +# LD block with the per-block GwasSumStats RDS path the caller is expected to +# build (the `region` column drives that fan-out). # -# 1. reads each per-gene TwasWeights RDS to learn which genes have weights -# (the `trait` field) and which file holds each, -# 2. looks up each gene's chromosome + TSS in the xQTL meta table, -# 3. enumerates every LD block on the relevant chromosome(s) from the -# LD-meta TSV, and -# 4. assigns each gene's TwasWeights to its HOME block (the block whose -# [start, end) contains the gene's TSS) — assembleCtwasInputs uses a -# global GWAS-variant union so weight variants that straddle the block -# boundary still survive. +# Gene -> home-LD-block PLACEMENT is no longer done here: pecotmr's +# assembleCtwasInputs() now places each gene into its block internally from the +# `region` provenance carried on the TwasWeights / FineMappingResult (matching +# cTWAS's own p0 assignment rule). So this manifest is pecotmr-free and does NOT +# read the weights or the xQTL meta table — the weights are handed to +# ctwas_assemble.R as a single FLAT set, not bucketed per block. # -# The emitted manifest has one row per LD block, with the per-block -# GwasSumStats RDS path the caller is expected to build (region column drives -# that fan-out) and a (possibly empty) comma-separated TwasWeights list. -# -# NOTE: no data-layout path is hardcoded. The TwasWeights paths, meta tables, -# and the GwasSumStats output directory all come from arguments; the caller -# decides whether the weights are the upstream twas-step output or a -# substituted set. +# NOTE: no data-layout path is hardcoded. The LD-meta table and the GwasSumStats +# output directory come from arguments. # # Inputs: -# --ld-meta LD-meta TSV (#chr/start/end/path); rows are LD blocks -# --xqtl-meta xQTL meta TSV (region_id = gene, #chr, TSS, ...) -# --twas-weights Comma-separated per-gene TwasWeights RDS paths +# --ld-meta LD-meta TSV (#chr/start/end[/path]); rows are LD blocks # --gwas-sumstats-dir Directory the per-block GwasSumStats RDS live in # (path = /.gwas_sumstats.rds) # --chrom Optional chromosome filter (e.g. "22" or "chr22"); -# default: every chromosome that carries a weighted gene -# --output Output manifest TSV +# default: every chromosome in --ld-meta +# --output Output manifest TSV # -# Output columns: region_id, region, gwas_sumstats_rds, twas_weights_rds +# Output columns: region_id, region, gwas_sumstats_rds suppressPackageStartupMessages({ library(argparser) - library(pecotmr) }) -p <- arg_parser("Build the per-LD-block cTWAS manifest") +p <- arg_parser("Enumerate the per-LD-block cTWAS grid") p <- add_argument(p, "--ld-meta", type = "character", - help = "LD-meta TSV (#chr/start/end/path)") -p <- add_argument(p, "--xqtl-meta", type = "character", - help = "xQTL meta TSV (region_id = gene, #chr, TSS)") -p <- add_argument(p, "--twas-weights", type = "character", - help = "Comma-separated per-gene TwasWeights RDS paths") + help = "LD-meta TSV (#chr/start/end)") p <- add_argument(p, "--gwas-sumstats-dir", type = "character", help = "Directory holding the per-block GwasSumStats RDS") p <- add_argument(p, "--chrom", type = "character", default = "", - help = "Optional chromosome filter (default: chroms with genes)") + help = "Optional chromosome filter (default: all chroms in --ld-meta)") p <- add_argument(p, "--output", type = "character", help = "Output manifest TSV") argv <- parse_args(p) -splitCsv <- function(s) { - if (is.null(s) || is.na(s) || !nzchar(s)) return(character(0)) - trimws(strsplit(s, ",", fixed = TRUE)[[1L]]) -} -normChr <- function(x) sub("^chr", "", as.character(x), ignore.case = TRUE) - -weightPaths <- splitCsv(argv$twas_weights) -if (length(weightPaths) == 0L) - stop("--twas-weights lists no TwasWeights RDS paths.") - -# ---- gene -> weights file (read each RDS; trait field is the gene id) ------- -geneToWeight <- list() -for (wp in weightPaths) { - if (!file.exists(wp)) stop("TwasWeights RDS not found: ", wp) - tw <- readRDS(wp) - if (!methods::is(tw, "TwasWeights")) - stop("Not a TwasWeights RDS: ", wp) - for (g in unique(as.character(tw$trait))) { - geneToWeight[[g]] <- union(geneToWeight[[g]], wp) - } -} -genes <- names(geneToWeight) +.d <- dirname(sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +source(file.path(.d, "manifest_common.R")) -# ---- gene -> (chrom, TSS) from the xQTL meta ------------------------------- -xqtl <- read.table(argv$xqtl_meta, header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, - comment.char = "") -xchr <- intersect(c("#chr", "#chrom", "chr", "chrom"), names(xqtl))[1L] -if (is.na(xchr) || !all(c("region_id", "TSS") %in% names(xqtl))) - stop("--xqtl-meta needs region_id, TSS and a chromosome column; got: ", - paste(names(xqtl), collapse = ", ")) -xqtl <- xqtl[!duplicated(xqtl$region_id), , drop = FALSE] -geneChr <- setNames(normChr(xqtl[[xchr]]), xqtl$region_id) -geneTss <- setNames(suppressWarnings(as.integer(xqtl$TSS)), xqtl$region_id) -missing <- setdiff(genes, names(geneChr)) -if (length(missing) > 0L) - stop("Genes have TwasWeights but are absent from --xqtl-meta: ", - paste(missing, collapse = ", ")) - -# Chromosomes in scope: the --chrom filter, else every chrom carrying a gene. -chromsWithGenes <- unique(geneChr[genes]) -chroms <- if (nzchar(argv$chrom)) normChr(argv$chrom) else chromsWithGenes -if (nzchar(argv$chrom)) - genes <- genes[geneChr[genes] %in% chroms] - -# ---- enumerate LD blocks for the in-scope chromosomes ---------------------- -ld <- read.table(argv$ld_meta, header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, - comment.char = "") +# ---- enumerate LD blocks --------------------------------------------------- +ld <- readMeta(argv$ld_meta) ldChrCol <- intersect(c("#chr", "#chrom", "chr", "chrom"), names(ld))[1L] if (is.na(ldChrCol)) stop("--ld-meta needs a chromosome column; got: ", paste(names(ld), collapse = ", ")) -ld$.chr <- normChr(ld[[ldChrCol]]) +ld$.chr <- chromStrip(ld[[ldChrCol]]) ld$.start <- suppressWarnings(as.integer(ld$start)) ld$.end <- suppressWarnings(as.integer(ld$end)) -ld <- ld[ld$.chr %in% chroms & !is.na(ld$.start) & !is.na(ld$.end), , drop = FALSE] +if (nzchar(argv$chrom)) + ld <- ld[ld$.chr %in% chromStrip(argv$chrom), , drop = FALSE] +ld <- ld[!is.na(ld$.start) & !is.na(ld$.end), , drop = FALSE] ld <- ld[!duplicated(ld[, c(".chr", ".start", ".end")]), , drop = FALSE] ld <- ld[order(ld$.chr, ld$.start), , drop = FALSE] if (nrow(ld) < 2L) @@ -124,29 +68,9 @@ region_id <- gsub("[:-]", "_", region) gwas_rds <- file.path(argv$gwas_sumstats_dir, paste0(region_id, ".gwas_sumstats.rds")) -# ---- assign each gene to its home block (TSS in [start, end)) -------------- -twas_weights_rds <- rep("", nrow(ld)) -for (g in genes) { - hit <- which(ld$.chr == geneChr[[g]] & - geneTss[[g]] >= ld$.start & geneTss[[g]] < ld$.end) - if (length(hit) == 0L) { - warning("Gene ", g, " (TSS ", geneTss[[g]], ") falls in no LD block; skipped.") - next - } - h <- hit[[1L]] - cur <- splitCsv(twas_weights_rds[[h]]) - twas_weights_rds[[h]] <- paste(union(cur, geneToWeight[[g]]), collapse = ",") -} - -placed <- sum(nzchar(twas_weights_rds)) -if (placed == 0L) - stop("No gene was placed into any LD block; check --xqtl-meta TSS vs --ld-meta.") - out <- data.frame(region_id = region_id, region = region, gwas_sumstats_rds = gwas_rds, - twas_weights_rds = twas_weights_rds, stringsAsFactors = FALSE) -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -write.table(out, file = argv$output, sep = "\t", quote = FALSE, row.names = FALSE) -cat(sprintf("Wrote cTWAS manifest: %d LD block(s), %d gene-bearing, to %s\n", - nrow(out), placed, argv$output)) +writeManifest(out, argv$output) +cat(sprintf("Wrote cTWAS block grid: %d LD block(s) to %s\n", + nrow(out), argv$output)) diff --git a/code/script/pecotmr_integration/enloc_manifest.R b/code/script/pecotmr_integration/enloc_manifest.R new file mode 100644 index 000000000..fc38dd3fa --- /dev/null +++ b/code/script/pecotmr_integration/enloc_manifest.R @@ -0,0 +1,171 @@ +#!/usr/bin/env Rscript +# enloc_manifest.R +# +# Resolve SuSiE_enloc.ipynb's per-analysis-unit QTL x GWAS pairings into a +# manifest TSV, replacing the in-notebook pandas machinery +# (get_analysis_regions / get_overlapped_analysis_regions and their 11 helper +# defs). Downstream [xqtl_gwas_enrichment] / [susie_coloc] fan out over the +# manifest rows with inline csv.DictReader (no notebook-local Python). +# +# Two modes (one fan-out unit per output row): +# --mode enrichment (drives xqtl_gwas_enrichment): an xQTL region is paired +# with every GWAS block it overlaps by COORDINATE +# ([start,end] intersect); units are grouped by CONDITION +# (unit_id = condition). +# --mode coloc (drives susie_coloc): an xQTL region is paired with the +# GWAS blocks that share top-loci variants (its +# `block_top_loci` column); one unit per (condition,region) +# (unit_id = "condition@region_id"). +# +# In both modes each condition (from conditions_top_loci[_minp]) is routed to the +# QTL file of ITS study via --context-meta: a context that is a substring of the +# condition maps to an analysis_name, and only QTL files whose name contains that +# analysis_name (case-insensitive) are kept. With no --context-meta and a single +# QTL file per region, the context step is skipped. +# +# Output columns (one row per unit): unit_id, qtl_files, gwas_files +# (qtl_files / gwas_files are comma-separated, path-prefixed by --qtl-path / +# --gwas-path). No data-layout path is hardcoded. + +suppressPackageStartupMessages(library(argparser)) + +p <- arg_parser("Resolve enloc QTL x GWAS analysis units into a manifest TSV") +p <- add_argument(p, "--mode", type = "character", + help = "enrichment | coloc") +p <- add_argument(p, "--xqtl-meta", type = "character", help = "xQTL meta TSV") +p <- add_argument(p, "--gwas-meta", type = "character", help = "GWAS meta TSV") +p <- add_argument(p, "--context-meta", type = "character", default = "", + help = "context->analysis_name meta TSV (analysis_name, context)") +p <- add_argument(p, "--qtl-path", type = "character", default = "", + help = "prefix dir for QTL files") +p <- add_argument(p, "--gwas-path", type = "character", default = "", + help = "prefix dir for GWAS files") +p <- add_argument(p, "--region-list", type = "character", default = "", + help = "optional file; LAST column lists region_ids to keep") +p <- add_argument(p, "--region-name", type = "character", default = "", + help = "optional comma-separated region_ids to keep") +p <- add_argument(p, "--gwas-finemapping-obj", type = "character", nargs = Inf, + default = NA_character_, + help = "optional cohort/method tokens to filter GWAS conditions_top_loci") +p <- add_argument(p, "--minp", flag = TRUE, + help = "use conditions_top_loci_minp (top isoform only)") +p <- add_argument(p, "--output", type = "character", help = "output manifest TSV") +argv <- parse_args(p) + +.d <- dirname(sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +source(file.path(.d, "manifest_common.R")) + +mode <- match.arg(argv$mode, c("enrichment", "coloc")) + +notNa <- function(v) !is.na(v) & nzchar(trimws(as.character(v))) + +xqtl <- readMeta(argv$xqtl_meta) +gwas <- readMeta(argv$gwas_meta) +gfo <- { v <- argv$gwas_finemapping_obj; v <- v[!is.na(v)]; trimws(v)[nzchar(trimws(v))] } +tlcol <- if (argv$minp) "conditions_top_loci_minp" else "conditions_top_loci" + +# ---- mode-specific: filter + per-region block_data (the overlapping GWAS) ---- +if (mode == "enrichment") { + xqtl <- xqtl[notNa(xqtl[[tlcol]]), , drop = FALSE] + gwas <- gwas[notNa(gwas$conditions_top_loci), , drop = FALSE] + gfo2 <- setdiff(gfo, "susie_result_trimmed") + if (length(gfo2) > 0L) + gwas <- gwas[grepl(paste(gfo2, collapse = "|"), gwas$conditions_top_loci), , drop = FALSE] + # xQTL region [start,end] intersects GWAS block [start,end] on the same chrom + blk <- vector("list", nrow(xqtl)) + for (j in seq_len(nrow(gwas))) { + g <- gwas[j, ] + hit <- which(xqtl[["#chr"]] == g[["#chr"]] & + suppressWarnings(as.integer(xqtl$start)) <= as.integer(g$end) & + suppressWarnings(as.integer(xqtl$end)) >= as.integer(g$start)) + for (k in hit) blk[[k]] <- c(blk[[k]], g$original_data) + } + xqtl$block_data <- vapply(blk, function(b) if (is.null(b)) NA_character_ else makeUnique(joinC(b)), + character(1)) + xqtl <- xqtl[notNa(xqtl$block_data), , drop = FALSE] +} else { + xqtl <- xqtl[notNa(xqtl$block_top_loci), , drop = FALSE] + gwas <- gwas[notNa(gwas$conditions_top_loci), , drop = FALSE] + gfo2 <- setdiff(gfo, c("susie_result_trimmed", "RSS_QC_RAISS_imputed")) + if (length(gfo2) > 0L) + gwas <- gwas[grepl(paste(gfo2, collapse = "|"), gwas$conditions_top_loci), , drop = FALSE] + btlIds <- unique(unlist(lapply(xqtl$block_top_loci, splitC))) + gwas <- gwas[gwas$region_id %in% btlIds, , drop = FALSE] + r2d <- setNames(gwas$original_data, gwas$region_id) + xqtl$block_data <- vapply(xqtl$block_top_loci, function(bt) { + ids <- splitC(bt); makeUnique(joinC(unname(r2d[ids[ids %in% names(r2d)]]))) + }, character(1)) +} +if (nrow(xqtl) == 0L) stop("enloc_manifest: no xQTL regions after ", mode, " filtering.") + +# ---- optional region restriction -------------------------------------------- +regionIds <- character(0) +if (nzchar(argv$region_list) && argv$region_list != "." && file.exists(argv$region_list)) { + rl <- readTableNoHeader(argv$region_list) + regionIds <- unique(as.character(rl[[ncol(rl)]])) +} +rn <- splitC(argv$region_name) +if (length(rn) > 0L) regionIds <- union(regionIds, rn) +if (length(regionIds) > 0L) + xqtl <- xqtl[xqtl$region_id %in% regionIds, , drop = FALSE] + +# ---- condition-based expansion: one row per (condition, region) -------------- +rows <- list() +for (i in seq_len(nrow(xqtl))) { + r <- xqtl[i, ] + for (cond in splitC(r[[tlcol]])) + rows[[length(rows) + 1L]] <- data.frame( + condition = cond, region_id = r$region_id, + QTL = r$original_data, GWAS = r$block_data, stringsAsFactors = FALSE) +} +if (length(rows) == 0L) stop("enloc_manifest: no (condition, region) pairs produced.") +cb <- do.call(rbind, rows) + +# ---- context routing: keep each condition's own study's QTL file ------------- +useCtx <- nzchar(argv$context_meta) && argv$context_meta != "." && file.exists(argv$context_meta) +singleFile <- all(vapply(cb$QTL, function(q) length(splitC(q)) <= 1L, logical(1))) +if (useCtx || !singleFile) { + if (!useCtx) + stop("enloc_manifest: multiple QTL files per region require --context-meta to route conditions.") + ctx <- readMeta(argv$context_meta) + ctxLong <- do.call(rbind, lapply(seq_len(nrow(ctx)), function(k) + data.frame(context = splitC(ctx$context[k]), analysis_name = ctx$analysis_name[k], + stringsAsFactors = FALSE))) + kept <- list() + for (i in seq_len(nrow(cb))) { + row <- cb[i, ] + ans <- unique(ctxLong$analysis_name[vapply(ctxLong$context, + function(c) grepl(c, row$condition, fixed = TRUE), logical(1))]) + files <- splitC(row$QTL) + keep <- files[vapply(files, function(f) + any(vapply(ans, function(a) grepl(tolower(a), tolower(f), fixed = TRUE), logical(1))), + logical(1))] + if (length(keep) > 0L) + kept[[length(kept) + 1L]] <- data.frame(condition = row$condition, region_id = row$region_id, + QTL = joinC(keep), GWAS = makeUnique(row$GWAS), stringsAsFactors = FALSE) + } + if (length(kept) == 0L) stop("enloc_manifest: context routing dropped every unit.") + cb <- do.call(rbind, kept) +} else { + cb$GWAS <- vapply(cb$GWAS, makeUnique, character(1)) +} + +# ---- path prefixing --------------------------------------------------------- +cb$QTL <- vapply(cb$QTL, prefixPaths, character(1), pre = argv$qtl_path) +cb$GWAS <- vapply(cb$GWAS, prefixPaths, character(1), pre = argv$gwas_path) + +# ---- emit units ------------------------------------------------------------- +if (mode == "enrichment") { + out <- do.call(rbind, lapply(unique(cb$condition), function(cond) { + s <- cb[cb$condition == cond, , drop = FALSE] + data.frame(unit_id = cond, + qtl_files = joinC(splitC(joinC(s$QTL))), + gwas_files = makeUnique(joinC(s$GWAS)), stringsAsFactors = FALSE) + })) +} else { + out <- data.frame(unit_id = paste0(cb$condition, "@", cb$region_id), + qtl_files = cb$QTL, gwas_files = cb$GWAS, stringsAsFactors = FALSE) +} + +writeManifest(out, argv$output) +cat(sprintf("Wrote enloc %s manifest with %d unit(s) to %s\n", mode, nrow(out), argv$output)) diff --git a/code/script/pecotmr_integration/fine_mapping.R b/code/script/pecotmr_integration/fine_mapping.R index ea494b3c7..3dbfd7c59 100644 --- a/code/script/pecotmr_integration/fine_mapping.R +++ b/code/script/pecotmr_integration/fine_mapping.R @@ -54,8 +54,6 @@ suppressPackageStartupMessages({ library(argparser) library(pecotmr) - library(GenomicRanges) - library(IRanges) library(jsonlite) }) @@ -108,6 +106,12 @@ parser <- add_argument(parser, "--method-args", parser <- add_argument(parser, "--seed", help = "Integer RNG seed set before fitting (reproducibility); unset = no seeding", type = "integer", default = NA) +parser <- add_argument(parser, "--cv-folds", + help = "Cross-validation folds for the mash-prior / predictive refits (fineMappingPipeline cvFolds); 0 = off", + type = "integer", default = 0L) +parser <- add_argument(parser, "--cv-threads", + help = "Parallel workers for the cross-validation fold refits (fineMappingPipeline cvThreads); -1 = all cores", + type = "integer", default = 1L) parser <- add_argument(parser, "--pip-cutoff-to-skip", help = "Single-effect (SER) pre-screen cutoff (fineMappingPipeline pipCutoffToSkip), QTL mode; 0 = off, <0 = adaptive 3/nVariants", type = "numeric", default = 0) @@ -141,6 +145,9 @@ parser <- add_argument(parser, "--joint-specification", parser <- add_argument(parser, "--twas-weights", help = "Optional TwasWeights RDS (preceding mr.mash run) supplying the mvSuSiE data-driven prior; omit for the canonical prior", type = "character", default = "") +parser <- add_argument(parser, "--fine-mapping-result", + help = "Optional existing FineMappingResult RDS used as a resume cache (fineMappingPipeline fineMappingResult); (study, context, trait, method) tuples already present are not refit", + type = "character", default = "") parser <- add_argument(parser, "--data-driven-prior-weights-cutoff", help = "Prior-component weight floor for the reweighted mvSuSiE prior (only used with --twas-weights)", type = "numeric", default = 1e-10) @@ -174,24 +181,38 @@ parser <- add_argument(parser, "--keep-samples", parser <- add_argument(parser, "--keep-variants", help = "Path to a whitespace-delimited file of variant IDs to restrict to (overrides keepVariants)", type = "character", default = "") +parser <- add_argument(parser, "--full-fit", + help = "Widen per-CS variant matrices (within_cs_pip_cs, ...) onto topLoci; default emits only the within_cs_pip scalar", + flag = TRUE) +parser <- add_argument(parser, "--full-fit-all", + help = "With --full-fit, widen ALL per-CS matrices (alpha + logbf + effect + effect-variance), not just alpha", + flag = TRUE) +parser <- add_argument(parser, "--include-all-cs", + help = "With --full-fit, include effects that produced no passing (purity/coverage) credible set", + flag = TRUE) parser <- add_argument(parser, "--output", help = "Output RDS path", type = "character") argv <- parse_args(parser) -# Opt-in overrides of a loaded QtlDataset's construct-time filter slots. Filters -# apply lazily at extraction, so mutating the slot re-filters without rebuilding -# the RDS. Shared by both QTL workers (see twas_weights.R). -apply_qd_filter_overrides <- function(qd, argv) { - if (!is.na(argv$maf_cutoff)) qd@mafCutoff <- argv$maf_cutoff - if (!is.na(argv$mac_cutoff)) qd@macCutoff <- argv$mac_cutoff - if (!is.na(argv$xvar_cutoff)) qd@xvarCutoff <- argv$xvar_cutoff - if (!is.na(argv$imiss_cutoff)) qd@imissCutoff <- argv$imiss_cutoff - if (isTRUE(argv$drop_indel)) qd@keepIndel <- FALSE - read_ids <- function(p) if (nzchar(p) && p != "." && file.exists(p)) - unique(trimws(unlist(strsplit(readLines(p), "[[:space:]]+")))) else NULL - ks <- read_ids(argv$keep_samples); if (!is.null(ks)) qd@keepSamples <- ks - kv <- read_ids(argv$keep_variants); if (!is.null(kv)) qd@keepVariants <- kv - qd +# Read a whitespace-delimited ID file into a unique character vector; NULL when +# the path is empty / "." / missing. +read_ids <- function(p) if (nzchar(p) && p != "." && file.exists(p)) + unique(trimws(unlist(strsplit(readLines(p), "[[:space:]]+")))) else NULL + +# Build the per-call genotype-filter overrides as pipeline ARGUMENTS (NULL = +# leave the QtlDataset's construct-time slot untouched). The pipeline applies +# these to a validated copy; the wrapper no longer mutates @slots directly. +# Mirrored in twas_weights.R. +qd_filter_overrides <- function(argv) { + ov <- list( + mafCutoff = if (!is.na(argv$maf_cutoff)) argv$maf_cutoff else NULL, + macCutoff = if (!is.na(argv$mac_cutoff)) argv$mac_cutoff else NULL, + xvarCutoff = if (!is.na(argv$xvar_cutoff)) argv$xvar_cutoff else NULL, + imissCutoff = if (!is.na(argv$imiss_cutoff)) argv$imiss_cutoff else NULL, + keepIndel = if (isTRUE(argv$drop_indel)) FALSE else NULL, + keepSamples = read_ids(argv$keep_samples), + keepVariants = read_ids(argv$keep_variants)) + ov[!vapply(ov, is.null, logical(1))] } # Parse --method-args into a nested named list of per-method kwargs. @@ -227,15 +248,6 @@ median_abs_corr <- if (length(argv$median_abs_corr) != 1L || is.na(argv$median_a # Seed up front for reproducible fits (mirrors the legacy susie_twas set.seed). if (length(argv$seed) == 1L && !is.na(argv$seed)) set.seed(as.integer(argv$seed)) -parse_region <- function(s) { - m <- regmatches(s, regexec("^([^:]+):([0-9]+)-([0-9]+)$", s))[[1L]] - if (length(m) != 4L) - stop("--region must be in chr:start-end format (got: ", s, ")") - GRanges(seqnames = m[[2L]], - ranges = IRanges(start = as.integer(m[[3L]]), - end = as.integer(m[[4L]]))) -} - has_qtl <- nzchar(argv$qtl_dataset) has_gwas <- nzchar(argv$gwas_sumstats) if (has_qtl && has_gwas) @@ -255,6 +267,10 @@ joint_spec <- if (nzchar(argv$joint_specification) && argv$joint_specification ! # Optional mr.mash data-driven prior (TwasWeights from a preceding mrmash run). twas_weights_obj <- if (nzchar(argv$twas_weights) && argv$twas_weights != "." && file.exists(argv$twas_weights)) readRDS(argv$twas_weights) else NULL +# Optional existing FineMappingResult used as a resume cache (checkpointing): +# tuples already present are not refit. +fmr_obj <- if (nzchar(argv$fine_mapping_result) && argv$fine_mapping_result != "." && + file.exists(argv$fine_mapping_result)) readRDS(argv$fine_mapping_result) else NULL # Build the `methods` argument: the bare tokens, or the named-list {token: kwargs} # form when --method-args is given. SuSiE L / L_greedy defaults + susie-family @@ -283,8 +299,17 @@ cs_args <- list(methods = methods_arg, coverage = argv$coverage, secondaryCoverage = secondary_cov, signalCutoff = argv$pip_cutoff, - minAbsCorr = argv$min_abs_corr) + minAbsCorr = argv$min_abs_corr, + # Per-CS variant-level export: default emits within_cs_pip only; + # --full-fit widens per-CS matrices (alpha; +logbf/effect/effect-var + # with --full-fit-all; +filtered CS with --include-all-cs). + fullFit = isTRUE(argv[["full_fit"]]), + fullFitAlphaOnly = !isTRUE(argv[["full_fit_all"]]), + includeAllCs = isTRUE(argv[["include_all_cs"]])) if (!is.null(median_abs_corr)) cs_args$medianAbsCorr <- median_abs_corr +# Resume cache applies to both QTL and GWAS modes (both pipeline methods accept +# fineMappingResult). Added only when supplied, for pecotmr-version tolerance. +if (!is.null(fmr_obj)) cs_args$fineMappingResult <- fmr_obj if (has_gwas) { # ----- GWAS mode ------------------------------------------------------- @@ -316,15 +341,17 @@ if (has_gwas) { if (!has_gene && !has_region) stop("QTL mode requires --gene-id (with --cis-window) or --region.") qd <- readRDS(argv$qtl_dataset) - qd <- apply_qd_filter_overrides(qd, argv) # `contexts` and `pipCutoffToSkip` are QTL-mode only, so they ride on qtl_args - # rather than the mode-shared cs_args. + # rather than the mode-shared cs_args. Genotype-filter overrides are passed as + # pipeline arguments (applied to a validated copy inside the pipeline). # cisWindow is a gene-mode (traitId) knob — it expands each trait's own # coordinates. In region mode the literal variant window comes from --region, # and passing both is an error, so cisWindow rides on the traitId branch only. - qtl_args <- c(list(qd), cs_args, + qtl_args <- c(list(qd), cs_args, qd_filter_overrides(argv), list(contexts = contexts_arg, - pipCutoffToSkip = argv$pip_cutoff_to_skip)) + pipCutoffToSkip = argv$pip_cutoff_to_skip, + cvFolds = argv$cv_folds, + cvThreads = argv$cv_threads)) # Opt-in multivariate / joint knobs. Each is added only when the user set it, # so the call stays compatible with a pecotmr that predates the argument # (mirrors the medianAbsCorr handling above). @@ -340,7 +367,7 @@ if (has_gwas) { label <- if (has_region) paste0("region '", argv$region, "'") else paste0("gene '", argv$gene_id, "'") run_fm <- function() if (has_region) { - do.call(fineMappingPipeline, c(qtl_args, list(region = parse_region(argv$region)))) + do.call(fineMappingPipeline, c(qtl_args, list(region = argv$region))) } else { do.call(fineMappingPipeline, c(qtl_args, list(traitId = argv$gene_id, diff --git a/code/script/pecotmr_integration/fine_mapping_cis_db_export.R b/code/script/pecotmr_integration/fine_mapping_cis_db_export.R new file mode 100644 index 000000000..6a7280d2a --- /dev/null +++ b/code/script/pecotmr_integration/fine_mapping_cis_db_export.R @@ -0,0 +1,125 @@ +#!/usr/bin/env Rscript +# fine_mapping_cis_db_export.R +# +# Modern replacement for the `cis_results_export` monster's per-region work. +# In the FMR pipeline the heavy legacy steps are already done upstream by +# fine_mapping.R (allele alignment via matchVariants, top-loci processing, CS +# purity), so per region this wrapper only: +# 1. combines the per-study/context FineMappingResult RDS(es) into the +# cis_results_db (itself an FMR) via combineFineMappingResults, and saves it; +# 2. saves the marginal sumstats table (getMarginalEffects) as the +# combined_data_sumstats db; +# 3. emits the enrichment meta row SuSiE_enloc reads and the pip_sum table. +# +# Meta schema (one tab-separated row), exactly as SuSiE_enloc consumes it: +# chr start end region_id TSS original_data combined_data +# combined_data_sumstats conditions conditions_top_loci +# TSS = start(getTraitPosition(db)) (NA when the trait position was never +# supplied, e.g. a QtlSumStats-derived FMR); conditions = getContexts; +# conditions_top_loci = contexts with >=1 top locus; chr/start/end default to +# getRegion(db) when not supplied via --chr/--start/--end. + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +parser <- arg_parser("Combine per-region FineMappingResult(s) into the cis_results_db + emit enrichment meta") +parser <- add_argument(parser, "--input", help = "Per-study/context FineMappingResult RDS path(s) to combine", + type = "character", nargs = Inf) +parser <- add_argument(parser, "--combined-data-output", help = "Path to write the combined db (FMR) RDS", + type = "character") +parser <- add_argument(parser, "--combined-data-sumstats-output", + help = "Optional path to write the marginal sumstats db RDS", + type = "character", default = NA) +parser <- add_argument(parser, "--region-id", help = "Region/gene id (default: unique trait, else region string)", + type = "character", default = NA) +parser <- add_argument(parser, "--chr", help = "Region chrom (default: getRegion)", type = "character", default = NA) +parser <- add_argument(parser, "--start", help = "Region start (default: getRegion)", type = "character", default = NA) +parser <- add_argument(parser, "--end", help = "Region end (default: getRegion)", type = "character", default = NA) +parser <- add_argument(parser, "--signal-cutoff", help = "PIP cutoff for conditions_top_loci", + type = "numeric", default = 0.025) +parser <- add_argument(parser, "--min-purity", help = "CS purity cutoff for conditions_top_loci; omit for none", + type = "numeric", default = NA) +parser <- add_argument(parser, "--meta-output", help = "Meta TSV output path", type = "character") +parser <- add_argument(parser, "--pip-sum-output", help = "Optional pip_sum TSV output path", + type = "character", default = NA) +argv <- parse_args(parser) + +inputs <- as.character(argv$input) +if (length(inputs) == 0L) stop("--input requires at least one FineMappingResult RDS path.") +minPurity <- if (is.na(argv$min_purity)) NULL else argv$min_purity + +# ---- 1. Combine per-study/context FMRs into the cis_results_db -------------- +fmrs <- lapply(inputs, function(p) { + x <- tryCatch(readRDS(p), error = function(e) NULL) + if (!methods::is(x, "FineMappingResultBase")) { + message("Skipping non-FineMappingResult input: ", p); return(NULL) + } + x +}) +fmrs <- Filter(Negate(is.null), fmrs) +if (length(fmrs) == 0L) stop("No FineMappingResult inputs could be read.") +db <- if (length(fmrs) == 1L) fmrs[[1L]] else Reduce(combineFineMappingResults, fmrs) + +dir.create(dirname(argv$combined_data_output), showWarnings = FALSE, recursive = TRUE) +saveRDS(db, argv$combined_data_output) + +# ---- 2. Marginal sumstats db (optional) ------------------------------------ +if (!is.na(argv$combined_data_sumstats_output)) { + me <- tryCatch(as.data.frame(getMarginalEffects(db)), error = function(e) NULL) + dir.create(dirname(argv$combined_data_sumstats_output), showWarnings = FALSE, recursive = TRUE) + saveRDS(me, argv$combined_data_sumstats_output) +} + +# ---- 3. FMR-derived meta fields -------------------------------------------- +tp <- getTraitPosition(db) +TSS <- if (methods::is(tp, "GRanges") && length(tp) > 0L) GenomicRanges::start(tp)[1L] else NA + +ctx <- getContexts(db) +conditions <- if (is.null(ctx)) "" else paste(unique(as.character(ctx)), collapse = ",") + +tl <- tryCatch(as.data.frame(getTopLoci(db, signalCutoff = argv$signal_cutoff, minPurity = minPurity)), + error = function(e) NULL) +conditions_top_loci <- if (!is.null(tl) && nrow(tl) > 0L && "context" %in% names(tl)) + paste(unique(as.character(tl$context)), collapse = ",") else "" + +regionId <- if (!is.na(argv$region_id)) argv$region_id else { + tr <- unique(as.character(db$trait)); if (length(tr) == 1L) tr else NA +} +rg <- tryCatch(getRegion(db), error = function(e) NULL) +gr1 <- function(fn, i) if (methods::is(rg, "GRanges") && length(rg) > 0L) fn(rg)[i] else NA +chr <- if (!is.na(argv$chr)) argv$chr else as.character(gr1(GenomicRanges::seqnames, 1L)) +start <- if (!is.na(argv$start)) argv$start else gr1(GenomicRanges::start, 1L) +end <- if (!is.na(argv$end)) argv$end else gr1(GenomicRanges::end, 1L) + +meta <- data.frame( + chr = chr, start = start, end = end, region_id = regionId, TSS = TSS, + original_data = paste(basename(inputs), collapse = ","), + combined_data = basename(argv$combined_data_output), + combined_data_sumstats = if (!is.na(argv$combined_data_sumstats_output)) + basename(argv$combined_data_sumstats_output) else "", + conditions = conditions, + conditions_top_loci = conditions_top_loci, + stringsAsFactors = FALSE) + +dir.create(dirname(argv$meta_output), showWarnings = FALSE, recursive = TRUE) +write.table(meta, file = argv$meta_output, sep = "\t", quote = FALSE, row.names = FALSE, na = "NA") +cat(sprintf("Wrote cis_results_db (%d FMR input(s) -> %d rows) + meta (region_id=%s, TSS=%s) to %s\n", + length(fmrs), nrow(db), regionId, as.character(TSS), argv$combined_data_output)) + +# ---- 4. pip_sum (optional) ------------------------------------------------- +if (!is.na(argv$pip_sum_output)) { + rows <- lapply(seq_len(nrow(db)), function(i) { + sel <- list(study = as.character(db$study[i]), context = as.character(db$context[i]), + trait = as.character(db$trait[i]), method = as.character(db$method[i])) + pip <- tryCatch(do.call(getPip, c(list(db), sel)), error = function(e) NULL) + if (is.null(pip)) return(NULL) + data.frame(pip_sum = sum(pip[pip > 0], na.rm = TRUE), condition = sel$context, + stringsAsFactors = FALSE) + }) + pipSum <- do.call(rbind, Filter(Negate(is.null), rows)) + if (is.null(pipSum)) pipSum <- data.frame(pip_sum = numeric(0), condition = character(0)) + dir.create(dirname(argv$pip_sum_output), showWarnings = FALSE, recursive = TRUE) + write.table(pipSum, file = argv$pip_sum_output, sep = "\t", quote = FALSE, row.names = FALSE) +} diff --git a/code/script/pecotmr_integration/fine_mapping_export.R b/code/script/pecotmr_integration/fine_mapping_export.R index 0f46eb0b2..d651f37c5 100644 --- a/code/script/pecotmr_integration/fine_mapping_export.R +++ b/code/script/pecotmr_integration/fine_mapping_export.R @@ -26,51 +26,50 @@ parser <- add_argument(parser, "--input", help = "One or more FineMappingResult RDS paths", type = "character", nargs = Inf) parser <- add_argument(parser, "--view", - help = "Which view to export: topLoci | cs | pip | marginals", + help = "topLoci | cs | cs_summary | pip | marginals | credible_band | affected_regions", type = "character", default = "topLoci") parser <- add_argument(parser, "--signal-cutoff", help = "PIP cutoff for topLoci/pip exports", type = "numeric", default = 0) +parser <- add_argument(parser, "--min-purity", + help = "Optional CS purity (min.abs.corr) cutoff for topLoci/cs (independent of coverage/pip); omit = no filter", + type = "numeric", default = NA) parser <- add_argument(parser, "--output", help = "Output TSV path", type = "character") argv <- parse_args(parser) -view <- match.arg(argv$view, c("topLoci", "cs", "pip", "marginals")) +view <- match.arg(argv$view, c("topLoci", "cs", "cs_summary", "pip", "marginals", + "lbf", "credible_band", "affected_regions")) inputs <- as.character(argv$input) if (length(inputs) == 0L) stop("--input requires at least one RDS path.") +minPurity <- if (is.na(argv$min_purity)) NULL else argv$min_purity -# Pull the row's identifier columns regardless of QTL vs GWAS shape; the -# union of slots produces a NA-padded data frame the downstream rbind can -# concatenate across mixed inputs. -.idCols <- function(fmr, i) { - list( - study = as.character(fmr$study)[[i]], - context = if ("context" %in% names(fmr)) as.character(fmr$context)[[i]] else NA_character_, - trait = if ("trait" %in% names(fmr)) as.character(fmr$trait)[[i]] else NA_character_, - region_id = if ("region_id" %in% names(fmr)) as.character(fmr$region_id)[[i]] else NA_character_, - method = as.character(fmr$method)[[i]], - source = basename(attr(fmr, ".source", exact = TRUE) %||% "")) -} -`%||%` <- function(a, b) if (is.null(a)) b else a - -.extract <- function(entry, view, cutoff) { - if (view == "topLoci") { - df <- as.data.frame(getTopLoci(entry, signalCutoff = cutoff)) - } else if (view == "cs") { - df <- as.data.frame(getCs(entry)) - } else if (view == "pip") { - pip <- as.numeric(getPip(entry)) - ids <- as.character(getVariantIds(entry)) - df <- data.frame(variant_id = ids, pip = pip, - stringsAsFactors = FALSE) - if (cutoff > 0) df <- df[df$pip > cutoff, , drop = FALSE] - } else { # marginals - df <- as.data.frame(getMarginalEffects(entry)) - } - if (nrow(df) == 0L) return(NULL) - df -} +# Each view maps to a collection-level pecotmr accessor that already aggregates +# every entry into one tidy table carrying the row identity columns (study / +# context / trait / region_id / method) alongside the per-variant columns. The +# wrapper only tags each row with its source RDS and concatenates across inputs. +view_fn <- switch(view, + topLoci = function(fmr) + as.data.frame(getTopLoci(fmr, signalCutoff = argv$signal_cutoff, + minPurity = minPurity)), + cs = function(fmr) as.data.frame(getCs(fmr, minPurity = minPurity)), + # cs_summary: one row per credible set (size / purity / V / logBF / lead). + cs_summary = function(fmr) as.data.frame(getCredibleSetSummary(fmr)), + # lbf: wide variant x effect log Bayes factor matrix (lbf_L1..lbf_LL). + lbf = function(fmr) as.data.frame(getLbf(fmr)), + marginals = function(fmr) as.data.frame(getMarginalEffects(fmr)), + # fSuSiE functional views (require untrimmed fits; degrade to empty otherwise). + # credible_band = fitted effect curve + band; affected_regions = GRanges of + # the intervals where a CS's band excludes zero (coerced to a flat table). + credible_band = function(fmr) as.data.frame(fsusieCredibleBand(fmr)), + affected_regions = function(fmr) as.data.frame(fsusieAffectedRegions(fmr)), + # pip view: the (identity + variant_id + pip) projection of topLoci. + pip = function(fmr) { + tl <- as.data.frame(getTopLoci(fmr, signalCutoff = argv$signal_cutoff)) + tl[, intersect(c("study", "context", "trait", "region_id", "method", + "variant_id", "pip"), names(tl)), drop = FALSE] + }) pieces <- list() for (path in inputs) { @@ -79,21 +78,14 @@ for (path in inputs) { warning("Skipping non-FineMappingResult input: ", path) next } - attr(fmr, ".source") <- path - for (i in seq_len(nrow(fmr))) { - entry <- fmr$entry[[i]] - inner <- tryCatch(.extract(entry, view, argv$signal_cutoff), - error = function(e) { - message("Entry ", i, " of ", basename(path), - ": ", conditionMessage(e)) - NULL - }) - if (is.null(inner)) next - ids <- .idCols(fmr, i) - ids$source <- basename(path) - for (k in names(ids)) inner[[k]] <- ids[[k]] - pieces[[length(pieces) + 1L]] <- inner - } + df <- tryCatch(view_fn(fmr), + error = function(e) { + message(basename(path), ": ", conditionMessage(e)) + NULL + }) + if (is.null(df) || nrow(df) == 0L) next + df$source <- basename(path) + pieces[[length(pieces) + 1L]] <- df } if (length(pieces) == 0L) { message("No rows produced; writing an empty TSV with the id-column ", diff --git a/code/script/pecotmr_integration/fine_mapping_overlap.R b/code/script/pecotmr_integration/fine_mapping_overlap.R new file mode 100644 index 000000000..4510baea9 --- /dev/null +++ b/code/script/pecotmr_integration/fine_mapping_overlap.R @@ -0,0 +1,115 @@ +#!/usr/bin/env Rscript +# fine_mapping_overlap.R +# +# Overlap the top loci of a QTL FineMappingResult against one or more GWAS +# FineMappingResults, matching variants with pecotmr's allele-aware +# overlapTopLoci() (strand/ref-alt-swap aware; GWAS effects sign-flipped to the +# QTL orientation). Writes one concatenated TSV keyed on the QTL variant with +# every other column prefixed qtl_ / gwas_. +# +# Inputs: +# --qtl One QtlFineMappingResult RDS. +# --gwas [ ...] One or more GwasFineMappingResult RDS. +# --signal-cutoff PIP cutoff forwarded to overlapTopLoci for both +# sides. Default 0.025. +# --output Output TSV path (gzipped if it ends in .gz). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +parser <- arg_parser("Overlap QTL x GWAS top loci (allele-aware)") +parser <- add_argument(parser, "--qtl", + help = "QtlFineMappingResult RDS path(s) (combined if >1)", + type = "character", nargs = Inf) +parser <- add_argument(parser, "--gwas", + help = "One or more GwasFineMappingResult RDS paths", + type = "character", nargs = Inf) +parser <- add_argument(parser, "--signal-cutoff", + help = "PIP cutoff for both sides", type = "numeric", + default = 0.025) +parser <- add_argument(parser, "--output", + help = "Output TSV path (the overlap table)", type = "character") +# Optional enloc meta-update outputs: emit the QTL region's meta row with a +# `block_top_loci` column listing the GWAS blocks (region_ids) that share >=1 +# top-locus variant -- the column the coloc manifest (enloc_manifest.R --mode +# coloc) pairs on. +parser <- add_argument(parser, "--qtl-meta", + help = "Optional xQTL meta TSV to stamp block_top_loci onto", + type = "character", default = NA) +parser <- add_argument(parser, "--region-id", + help = "region_id row of --qtl-meta to update", type = "character", default = NA) +parser <- add_argument(parser, "--meta-output", + help = "Output path for the updated meta row", type = "character", default = NA) +argv <- parse_args(parser) + +# A QTL region may span several per-study FMRs (its meta original_data); combine +# them so overlapTopLoci sees the region's full top-loci set. +qtlPaths <- as.character(argv$qtl) +qtls <- lapply(qtlPaths, readRDS) +if (!all(vapply(qtls, function(x) methods::is(x, "QtlFineMappingResult"), logical(1)))) + stop("every --qtl input must be a QtlFineMappingResult RDS.") +qtl <- if (length(qtls) == 1L) qtls[[1L]] else Reduce(combineFineMappingResults, qtls) +gwasPaths <- as.character(argv$gwas) +if (length(gwasPaths) == 0L) + stop("--gwas requires at least one GwasFineMappingResult RDS.") + +pieces <- list() +blockTopLoci <- character(0) # GWAS blocks (region_ids) with >=1 shared variant +for (gp in gwasPaths) { + gwas <- readRDS(gp) + if (!methods::is(gwas, "GwasFineMappingResult")) { + warning("Skipping non-GwasFineMappingResult input: ", gp) + next + } + ov <- tryCatch( + as.data.frame(overlapTopLoci(qtl, gwas, signalCutoff = argv$signal_cutoff)), + error = function(e) { + message(basename(gp), ": ", conditionMessage(e)) + NULL + }) + if (is.null(ov) || nrow(ov) == 0L) next + ov$gwas_source <- basename(gp) + pieces[[length(pieces) + 1L]] <- ov + blockTopLoci <- c(blockTopLoci, unique(as.character(gwas$region_id))) +} +blockTopLoci <- unique(blockTopLoci) + +if (length(pieces) == 0L) { + message("No overlapping variants; writing an empty TSV with the key header.") + out <- data.frame(variant_id = character(0), chrom = character(0), + pos = integer(0), A1 = character(0), A2 = character(0), + gwas_source = character(0), stringsAsFactors = FALSE) +} else { + all_cols <- unique(unlist(lapply(pieces, names))) + for (k in seq_along(pieces)) { + miss <- setdiff(all_cols, names(pieces[[k]])) + for (m in miss) pieces[[k]][[m]] <- NA + pieces[[k]] <- pieces[[k]][, all_cols, drop = FALSE] + } + out <- do.call(rbind, pieces) +} + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +conn <- if (grepl("\\.gz$", argv$output)) gzfile(argv$output, "w") else file(argv$output, "w") +write.table(out, file = conn, sep = "\t", quote = FALSE, row.names = FALSE, na = "") +close(conn) +cat(sprintf("Wrote %d overlapping rows (%d GWAS input(s)) to %s\n", + nrow(out), length(gwasPaths), argv$output)) + +# Stamp block_top_loci onto the QTL region's meta row (for the coloc manifest). +if (!is.na(argv$meta_output) && !is.na(argv$qtl_meta)) { + meta <- read.delim(argv$qtl_meta, check.names = FALSE, stringsAsFactors = FALSE) + ridCol <- if ("region_id" %in% names(meta)) "region_id" else names(meta)[[4L]] + if (!is.na(argv$region_id)) + meta <- meta[as.character(meta[[ridCol]]) == argv$region_id, , drop = FALSE] + meta$block_top_loci <- if (length(blockTopLoci) > 0L) + paste(blockTopLoci, collapse = ",") else NA + dir.create(dirname(argv$meta_output), showWarnings = FALSE, recursive = TRUE) + write.table(meta, file = argv$meta_output, sep = "\t", quote = FALSE, + row.names = FALSE, na = "NA") + cat(sprintf("Stamped block_top_loci=%s onto %s\n", + if (length(blockTopLoci) > 0L) paste(blockTopLoci, collapse = ",") else "NA", + argv$meta_output)) +} diff --git a/code/script/pecotmr_integration/fine_mapping_pip_plot.R b/code/script/pecotmr_integration/fine_mapping_pip_plot.R index fa1801064..d62c82211 100644 --- a/code/script/pecotmr_integration/fine_mapping_pip_plot.R +++ b/code/script/pecotmr_integration/fine_mapping_pip_plot.R @@ -1,17 +1,21 @@ #!/usr/bin/env Rscript # fine_mapping_pip_plot.R # -# Render a per-region PIP landscape plot from a QtlFineMappingResult or -# GwasFineMappingResult RDS (output of fine_mapping.ipynb / -# multivariate_fine_mapping.ipynb / functional_fine_mapping.ipynb / -# rss_analysis.ipynb). One PNG per input RDS, one facet panel -# per row in the FMR. +# Render the per-region PIP landscape of a QtlFineMappingResult / +# GwasFineMappingResult RDS. Points are coloured by credible set and shaped by +# whether the variant is shared (in a CS) across >1 panel -- the same encoding +# as the legacy susie_pip_landscape_plot. When --annot-tibble is supplied (an +# Annotatr builtin-annotation TSV: seqnames/start/end/type/symbol), a +# regulatory-element track and a gene track are stacked under the PIP panel via +# cowplot, reproducing the legacy composite figure. Without it, only the PIP +# landscape is drawn (pecotmr carries no annotation resource). # # Inputs: -# --input Path to a FineMappingResult RDS -# --output Output PNG path -# --width PNG width (inches). Default 9. -# --height Per-panel PNG height (inches). Default 3. +# --input FineMappingResult RDS. +# --output Output plot path (.pdf / .png; device inferred). +# --annot-tibble Optional Annotatr annotation TSV for the overlay tracks. +# --width Plot width (inches). Default 12. +# --height Per-PIP-panel height (inches). Default 3. suppressPackageStartupMessages({ library(argparser) @@ -19,90 +23,119 @@ suppressPackageStartupMessages({ library(ggplot2) }) -parser <- arg_parser("Render a per-region PIP plot from a FineMappingResult RDS") -parser <- add_argument(parser, "--input", - help = "Path to a FineMappingResult RDS", - type = "character") -parser <- add_argument(parser, "--output", - help = "Output PNG path", type = "character") -parser <- add_argument(parser, "--width", - help = "PNG width in inches", - type = "numeric", default = 9) -parser <- add_argument(parser, "--height", - help = "Per-panel PNG height in inches", - type = "numeric", default = 3) +parser <- arg_parser("Render the PIP landscape of a FineMappingResult RDS") +parser <- add_argument(parser, "--input", help = "FineMappingResult RDS", type = "character") +parser <- add_argument(parser, "--output", help = "Output plot path (.pdf/.png)", type = "character") +parser <- add_argument(parser, "--annot-tibble", + help = "Optional Annotatr annotation TSV for the overlay tracks", + type = "character", default = NA) +parser <- add_argument(parser, "--width", help = "Plot width in inches", type = "numeric", default = 12) +parser <- add_argument(parser, "--height", help = "Per-PIP-panel height in inches", type = "numeric", default = 3) argv <- parse_args(parser) fmr <- readRDS(argv$input) if (!methods::is(fmr, "FineMappingResultBase")) - stop("--input must be a FineMappingResultBase subclass (got '", - class(fmr)[[1L]], "').") + stop("--input must be a FineMappingResultBase subclass (got '", class(fmr)[[1L]], "').") -write_empty <- function(msg) { +# Discrete palette matching the legacy plot (CS index -> colour). +palette <- c("black", "dodgerblue2", "green4", "#6A3D9A", "#FF7F00", "gold1", + "skyblue2", "#FB9A99", "palegreen2", "#CAB2D6", "#FDBF6F", "gray70", + "khaki2", "maroon", "orchid1", "deeppink1", "blue1", "steelblue4", + "darkturquoise", "green1", "yellow4", "yellow3", "darkorange4", + "brown", "navyblue", "#FF0000", "darkgreen", "#FFFF00", "purple") + +writeStub <- function(msg) { message(msg, "; writing an empty plot to ", argv$output) dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) - png(argv$output, width = argv$width * 100, height = argv$height * 100) - plot.new(); title(main = msg) - dev.off() + ggsave(argv$output, ggplot() + theme_void() + labs(title = msg), + width = argv$width, height = argv$height) } -if (nrow(fmr) == 0L) { - write_empty("Empty FineMappingResult") - quit(save = "no") -} +if (nrow(fmr) == 0L) { writeStub("Empty FineMappingResult"); quit(save = "no") } + +# getTopLoci(signalCutoff = 0): every fitted variant with pos, pip, CS membership +# (cs_95 = "_"), and the row-identity columns -> one facet panel. +tl <- tryCatch(as.data.frame(getTopLoci(fmr, signalCutoff = 0)), error = function(e) NULL) +if (is.null(tl) || nrow(tl) == 0L) { writeStub("No usable PIP vectors"); quit(save = "no") } -# Build a long tidy table of (panel-id, variant_id, pip) using the S4 -# accessors. The panel label varies by FMR shape: GWAS keeps region_id, -# QTL uses (context, trait). isGwas <- methods::is(fmr, "GwasFineMappingResult") -panels <- lapply(seq_len(nrow(fmr)), function(i) { - entry <- fmr$entry[[i]] - pip <- as.numeric(getPip(entry)) - ids <- as.character(getVariantIds(entry)) - if (length(pip) == 0L || length(ids) == 0L) return(NULL) - panel <- if (isGwas) { - sprintf("%s | %s | %s", - as.character(fmr$study)[[i]], - as.character(fmr$method)[[i]], - as.character(fmr$region_id)[[i]]) - } else { - sprintf("%s | %s | %s | %s", - as.character(fmr$study)[[i]], - as.character(fmr$context)[[i]], - as.character(fmr$trait)[[i]], - as.character(fmr$method)[[i]]) - } - data.frame(panel = panel, variant_id = ids, pip = pip, - stringsAsFactors = FALSE) -}) -panels <- panels[!vapply(panels, is.null, logical(1))] -if (length(panels) == 0L) { - write_empty("No usable PIP vectors on any entry") - quit(save = "no") +panel <- if (isGwas) { + sprintf("%s | %s | %s", tl$study, tl$method, tl$region_id) +} else { + sprintf("%s | %s | %s", tl$context, tl$trait, tl$method) } -df <- do.call(rbind, panels) +pos <- suppressWarnings(as.numeric(tl$pos)); pos[is.na(pos)] <- seq_len(nrow(tl))[is.na(pos)] +csIdx <- suppressWarnings(as.integer(sub(".*_", "", as.character(tl$cs_95)))) +csIdx[is.na(csIdx)] <- 0L +df <- data.frame(panel = panel, variant_id = as.character(tl$variant_id), + pip = as.numeric(tl$pip), pos = pos, CS = factor(csIdx), + stringsAsFactors = FALSE) +# Shared: a variant that sits in a credible set (CS != 0) in more than one panel. +inCs <- df[df$CS != "0", , drop = FALSE] +sharedIds <- unique(inCs$variant_id[duplicated(inCs$variant_id)]) +df$Shared <- df$variant_id %in% sharedIds -# Best-effort variant-id → position decode; falls back to row index. -pos <- suppressWarnings({ - m <- regmatches(df$variant_id, - regexec("^[^:_]+[:_]([0-9]+)", df$variant_id)) - vapply(m, function(x) if (length(x) >= 2L) as.numeric(x[[2L]]) else NA_real_, - numeric(1L)) -}) -df$pos <- ifelse(is.na(pos), seq_len(nrow(df)), pos) +plotRange <- c(min(df$pos), max(df$pos)) +chrom <- sub(":.*", "", df$variant_id[[1L]]) -g <- ggplot(df, aes(x = pos, y = pip)) + - geom_point(alpha = 0.6, size = 0.8) + - facet_wrap(~ panel, ncol = 1, scales = "free_x") + +pipPlot <- ggplot(df, aes(x = pos, y = pip, colour = CS, shape = Shared)) + + geom_point(size = 3, alpha = 0.8) + + facet_grid(panel ~ .) + + scale_colour_manual("CS", values = palette) + scale_y_continuous(limits = c(0, 1)) + - labs(x = "Variant position", y = "PIP", - title = paste0(class(fmr)[[1L]], ": ", basename(argv$input))) + - theme_minimal(base_size = 10) + labs(x = "", y = "PIP", title = paste0("Fine-mapping overview: ", basename(argv$input))) + + theme_minimal(base_size = 14) + + theme(strip.text.y.right = element_text(angle = 0)) + +panels <- list(pipPlot) +relHeights <- c(8) + +# Optional annotation overlay (regulatory-element + gene tracks) when the +# Annotatr tibble is supplied. Columns: seqnames, start, end, type, symbol. +if (!is.na(argv$annot_tibble) && file.exists(argv$annot_tibble)) { + annot <- tryCatch(read.delim(argv$annot_tibble, stringsAsFactors = FALSE), + error = function(e) NULL) + if (!is.null(annot) && all(c("seqnames", "start", "end", "type") %in% names(annot))) { + annot <- annot[annot$seqnames == chrom & annot$start > plotRange[1] & + annot$end < plotRange[2], , drop = FALSE] + reg <- annot[!annot$type %in% c("hg38_genes_introns", "hg38_genes_1to5kb"), , drop = FALSE] + if (nrow(reg) > 0L) { + panels <- c(panels, list( + ggplot(reg) + + geom_segment(aes(x = start, xend = end, y = "Regulatory", yend = "Regulatory", + colour = type), linewidth = 6) + + labs(x = "", y = "") + xlim(plotRange) + + theme_minimal(base_size = 12) + theme(axis.text.x = element_blank()))) + relHeights <- c(relHeights, 1) + } + genes <- annot[annot$type == "hg38_genes_1to5kb" & !is.na(annot$symbol), , drop = FALSE] + if (nrow(genes) > 0L) { + g <- do.call(rbind, lapply(split(genes, genes$symbol), function(s) + data.frame(symbol = s$symbol[[1L]], start = min(s$start), end = max(s$end)))) + panels <- c(panels, list( + ggplot(g) + + geom_segment(aes(x = start, xend = end, y = "Gene", yend = "Gene", colour = symbol), + linewidth = 6) + + geom_label(aes(x = (start + end) / 2, y = "Gene", label = symbol), size = 3) + + labs(x = "POS", y = "") + xlim(plotRange) + + theme_minimal(base_size = 12) + theme(legend.position = "none"))) + relHeights <- c(relHeights, 1) + } + } +} dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -ggsave(argv$output, g, - width = argv$width, - height = argv$height * length(unique(df$panel)), - dpi = 150) -cat(sprintf("Wrote PIP plot for %d panel(s) (%d variants) to %s\n", - length(unique(df$panel)), nrow(df), argv$output)) +nPanel <- length(unique(df$panel)) +if (length(panels) == 1L) { + ggsave(argv$output, pipPlot, width = argv$width, height = argv$height * nPanel, limitsize = FALSE) +} else if (requireNamespace("cowplot", quietly = TRUE)) { + grid <- cowplot::plot_grid(plotlist = panels, ncol = 1, align = "v", + axis = "tlbr", rel_heights = relHeights) + ggsave(argv$output, grid, width = argv$width, + height = argv$height * nPanel + 2 * (length(panels) - 1), limitsize = FALSE) +} else { + message("cowplot not installed; writing the PIP panel only.") + ggsave(argv$output, pipPlot, width = argv$width, height = argv$height * nPanel, limitsize = FALSE) +} +cat(sprintf("Wrote PIP landscape (%d panel(s), %d annotation track(s)) to %s\n", + nPanel, length(panels) - 1L, argv$output)) diff --git a/code/script/pecotmr_integration/fine_mapping_top_loci_bed.R b/code/script/pecotmr_integration/fine_mapping_top_loci_bed.R new file mode 100644 index 000000000..0b6343687 --- /dev/null +++ b/code/script/pecotmr_integration/fine_mapping_top_loci_bed.R @@ -0,0 +1,111 @@ +#!/usr/bin/env Rscript +# fine_mapping_top_loci_bed.R +# +# Export the top-loci BED for one or more QtlFineMappingResult / GwasFineMapping +# RDSes: the posterior view (getTopLoci, PIP/CS-filtered, with the independent +# purity filter) joined to the marginal effects (getMarginalEffects) and +# relabelled to the published BED schema. lfsr / conditional_effect are already +# per-(variant, context) numeric columns (no semicolon packing / re-splitting). +# +# Inputs: +# --input [ ...] FineMappingResult RDS paths. +# --signal-cutoff PIP cutoff (getTopLoci). Default 0.025. +# --min-purity Optional CS purity (min.abs.corr) cutoff, independent of +# coverage/pip. Omit for no purity filter. +# --output Output BED path (bgzipped/gzipped if it ends in .gz). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +parser <- arg_parser("Export the top-loci BED of FineMappingResult(s)") +parser <- add_argument(parser, "--input", help = "FineMappingResult RDS paths", + type = "character", nargs = Inf) +parser <- add_argument(parser, "--signal-cutoff", help = "PIP cutoff", + type = "numeric", default = 0.025) +parser <- add_argument(parser, "--min-purity", + help = "CS purity (min.abs.corr) cutoff; omit for none", + type = "numeric", default = NA) +parser <- add_argument(parser, "--output", help = "Output BED path", + type = "character") +argv <- parse_args(parser) + +inputs <- as.character(argv$input) +if (length(inputs) == 0L) stop("--input requires at least one RDS path.") +minPurity <- if (is.na(argv$min_purity)) NULL else argv$min_purity +idCols <- c("study", "context", "trait", "region_id", "method", "variant_id") + +# The published BED columns, in order; only those available are emitted. +bedFrom <- function(tl, me) { + # marginal effect columns (betahat/sebetahat/z), matched to the posterior rows + mm <- me[match( + do.call(paste, c(tl[intersect(idCols, names(tl))], sep = "\r")), + do.call(paste, c(me[intersect(idCols, names(me))], sep = "\r"))), , drop = FALSE] + pick <- function(df, col) if (col %in% names(df)) df[[col]] else NA + out <- data.frame( + chr = pick(tl, "chrom"), + pos = pick(tl, "pos"), + a1 = pick(tl, "A1"), + a2 = pick(tl, "A2"), + variant_ID = pick(tl, "variant_id"), + MAF = pick(tl, "af"), + betahat = pick(mm, "beta"), + sebetahat = pick(mm, "se"), + z = pick(mm, "z"), + gene_ID = pick(tl, "trait"), + event_ID = pick(tl, "context"), + cs_coverage_0.95 = pick(tl, "cs_95"), + cs_coverage_0.7 = pick(tl, "cs_70"), + cs_coverage_0.5 = pick(tl, "cs_50"), + cs_95_purity = pick(tl, "cs_95_purity"), + PIP = pick(tl, "pip"), + logBF = pick(tl, "logBF"), + conditional_effect = pick(tl, "conditional_effect"), + lfsr = pick(tl, "lfsr"), + region_id = pick(tl, "region_id"), + context = pick(tl, "context"), + stringsAsFactors = FALSE) + # Keep the full, stable BED schema (NA where a column does not apply, e.g. + # lfsr / conditional_effect for univariate methods) rather than dropping + # all-NA columns, so the published schema does not vary by input. Per-CS + # variant-level fullFit columns (within_cs_pip default +, when built with + # --full-fit, the wide within_cs_pip_cs / cs_logbf_ / cs_effect_ sets) are + # appended dynamically. + for (cc in grep("^(within_cs_pip|cs_logbf_|cs_effect_)", names(tl), value = TRUE)) + out[[cc]] <- tl[[cc]] + out +} + +pieces <- list() +for (path in inputs) { + fmr <- readRDS(path) + if (!methods::is(fmr, "FineMappingResultBase")) { + warning("Skipping non-FineMappingResult input: ", path); next + } + tl <- tryCatch(as.data.frame(getTopLoci(fmr, signalCutoff = argv$signal_cutoff, + minPurity = minPurity)), + error = function(e) { message(basename(path), ": ", conditionMessage(e)); NULL }) + if (is.null(tl) || nrow(tl) == 0L) next + me <- as.data.frame(getMarginalEffects(fmr)) + pieces[[length(pieces) + 1L]] <- bedFrom(tl, me) +} + +out <- if (length(pieces) == 0L) { + data.frame(chr = character(0), pos = integer(0), stringsAsFactors = FALSE) +} else { + cols <- unique(unlist(lapply(pieces, names))) + for (k in seq_along(pieces)) { + for (m in setdiff(cols, names(pieces[[k]]))) pieces[[k]][[m]] <- NA + pieces[[k]] <- pieces[[k]][, cols, drop = FALSE] + } + o <- do.call(rbind, pieces) + o[order(o$chr, suppressWarnings(as.numeric(o$pos))), , drop = FALSE] +} + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +conn <- if (grepl("\\.gz$", argv$output)) gzfile(argv$output, "w") else file(argv$output, "w") +write.table(out, file = conn, sep = "\t", quote = FALSE, row.names = FALSE, na = "") +close(conn) +cat(sprintf("Wrote %d top-loci BED rows from %d input(s) to %s\n", + nrow(out), length(inputs), argv$output)) diff --git a/code/script/pecotmr_integration/fine_mapping_upset.R b/code/script/pecotmr_integration/fine_mapping_upset.R index 4e7b5dcce..f119f4c42 100644 --- a/code/script/pecotmr_integration/fine_mapping_upset.R +++ b/code/script/pecotmr_integration/fine_mapping_upset.R @@ -46,8 +46,10 @@ inputs <- as.character(argv$input) if (length(inputs) == 0L) stop("--input requires at least one RDS path.") -# Walk every (FMR-row x CS) combination and build a named list of -# {set-label -> variant_ids} that UpSetR consumes via fromList(). +# Build a named list of {set-label -> variant_ids} for UpSetR::fromList(). +# getCs(fmr) aggregates every entry's credible sets into one table already +# tagged with the row identity (study/context/trait/region_id/method), so each +# per-tuple set is a split() on the label -- no per-entry loop. sets <- list() for (path in inputs) { fmr <- readRDS(path) @@ -55,27 +57,16 @@ for (path in inputs) { warning("Skipping non-FineMappingResult input: ", path) next } - isGwas <- methods::is(fmr, "GwasFineMappingResult") - for (i in seq_len(nrow(fmr))) { - entry <- fmr$entry[[i]] - cs_df <- tryCatch(as.data.frame(getCs(entry)), - error = function(e) NULL) - if (is.null(cs_df) || nrow(cs_df) == 0L) next - if (!"variant_id" %in% names(cs_df)) next - label <- if (isGwas) { - sprintf("%s|%s|%s", - as.character(fmr$study)[[i]], - as.character(fmr$method)[[i]], - as.character(fmr$region_id)[[i]]) - } else { - sprintf("%s|%s|%s|%s", - as.character(fmr$study)[[i]], - as.character(fmr$context)[[i]], - as.character(fmr$trait)[[i]], - as.character(fmr$method)[[i]]) - } - sets[[label]] <- unique(as.character(cs_df$variant_id)) + cs <- tryCatch(as.data.frame(getCs(fmr)), error = function(e) NULL) + if (is.null(cs) || nrow(cs) == 0L || !"variant_id" %in% names(cs)) next + label <- if (methods::is(fmr, "GwasFineMappingResult")) { + paste(cs$study, cs$method, cs$region_id, sep = "|") + } else { + paste(cs$study, cs$context, cs$trait, cs$method, sep = "|") } + perLabel <- split(as.character(cs$variant_id), label) + for (lab in names(perLabel)) + sets[[lab]] <- unique(c(sets[[lab]], perLabel[[lab]])) } if (length(sets) == 0L) { diff --git a/code/script/pecotmr_integration/fine_mapping_vcf.R b/code/script/pecotmr_integration/fine_mapping_vcf.R new file mode 100644 index 000000000..79827d80f --- /dev/null +++ b/code/script/pecotmr_integration/fine_mapping_vcf.R @@ -0,0 +1,41 @@ +#!/usr/bin/env Rscript +# fine_mapping_vcf.R +# +# Write a fine-mapping VCF (per-variant ES / CS / PIP in the sample column) from +# a QtlFineMappingResult / GwasFineMappingResult via pecotmr::writeSumstatsVcf. +# Replaces the legacy inline create_vcf() + VariantAnnotation::writeVcf in the +# mv_susie / uni_susie cells: the VCF assembly now lives in pecotmr's vcfWriter. +# +# Inputs: +# --input FineMappingResult RDS. +# --output Output VCF path (bgzipped + indexed when it ends .bgz/.gz). +# --sample-name VCF sample ("Studies") name. Default: the FMR study. +# --split-by-context Write one VCF per context (required when the collection +# has >1 row and no single row is selected). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +parser <- arg_parser("Write a fine-mapping VCF from a FineMappingResult") +parser <- add_argument(parser, "--input", help = "FineMappingResult RDS", type = "character") +parser <- add_argument(parser, "--output", help = "Output VCF path (.bgz/.gz => bgzipped+indexed)", + type = "character") +parser <- add_argument(parser, "--sample-name", help = "VCF sample/Studies name", + type = "character", default = NA) +parser <- add_argument(parser, "--split-by-context", help = "Write one VCF per context", + flag = TRUE) +argv <- parse_args(parser) + +fmr <- readRDS(argv$input) +if (!methods::is(fmr, "FineMappingResultBase")) + stop("--input must be a FineMappingResult RDS (got '", class(fmr)[[1L]], "').") + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +out <- writeSumstatsVcf( + fmr, outputPath = argv$output, + sampleName = if (is.na(argv$sample_name)) NULL else argv$sample_name, + splitByContext = argv$split_by_context) +cat(sprintf("Wrote %d fine-mapping VCF(s) from %s to %s\n", + length(out), basename(argv$input), argv$output)) diff --git a/code/script/pecotmr_integration/gwas_rss_manifest.R b/code/script/pecotmr_integration/gwas_rss_manifest.R index 904a0dec0..5ec7621e3 100644 --- a/code/script/pecotmr_integration/gwas_rss_manifest.R +++ b/code/script/pecotmr_integration/gwas_rss_manifest.R @@ -42,18 +42,21 @@ parser <- add_argument(parser, "--gwas-meta", type = "character", default = "") parser <- add_argument(parser, "--gwas-tsv-list", help = "Zero or more STUDY=PATH items", - type = "character", nargs = Inf, default = character(0)) + type = "character", nargs = Inf, default = NA_character_) parser <- add_argument(parser, "--region-list", help = "Optional BED-like region file", type = "character", default = "") parser <- add_argument(parser, "--regions", help = "Zero or more chr:start-end items", - type = "character", nargs = Inf, default = character(0)) + type = "character", nargs = Inf, default = NA_character_) parser <- add_argument(parser, "--output", help = "Output manifest TSV path", type = "character") argv <- parse_args(parser) +.d <- dirname(sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +source(file.path(.d, "manifest_common.R")) + # ----- Resolve per-study sources ---------------------------------------- studies <- data.frame(study_id = character(0), gwas_tsv = character(0), @@ -64,9 +67,7 @@ seenStudies <- character(0) if (nzchar(argv$gwas_meta) && argv$gwas_meta != ".") { if (!file.exists(argv$gwas_meta)) stop("--gwas-meta file not found: ", argv$gwas_meta) - meta <- read.table(argv$gwas_meta, header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, - comment.char = "") + meta <- readMeta(argv$gwas_meta) required <- c("study_id", "path") missing <- setdiff(required, names(meta)) if (length(missing) > 0L) @@ -93,7 +94,7 @@ if (nzchar(argv$gwas_meta) && argv$gwas_meta != ".") { } tsvItems <- as.character(argv$gwas_tsv_list) -tsvItems <- tsvItems[nzchar(tsvItems)] +tsvItems <- tsvItems[!is.na(tsvItems) & nzchar(tsvItems)] for (item in tsvItems) { if (!grepl("=", item, fixed = TRUE)) stop("--gwas-tsv-list expects STUDY=PATH items (got: ", item, ").") @@ -116,7 +117,7 @@ if (nrow(studies) == 0L) regions <- data.frame(chr = character(0), start = integer(0), end = integer(0), stringsAsFactors = FALSE) pushRegion <- function(chr, start, end) { - if (!startsWith(chr, "chr")) chr <- paste0("chr", chr) + chr <- chromAdd(chr) start <- as.integer(start); end <- as.integer(end) if (is.na(start) || is.na(end)) return(invisible(NULL)) key <- paste(chr, start, end, sep = "|") @@ -142,7 +143,7 @@ if (nzchar(argv$region_list) && argv$region_list != ".") { } regionItems <- as.character(argv$regions) -regionItems <- regionItems[nzchar(regionItems)] +regionItems <- regionItems[!is.na(regionItems) & nzchar(regionItems)] for (r in regionItems) { m <- regmatches(r, regexec("^([^:]+):([0-9]+)-([0-9]+)$", r))[[1L]] if (length(m) != 4L) @@ -170,8 +171,6 @@ for (i in seq_len(nrow(studies))) { } } out <- do.call(rbind, manifest) -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -write.table(out, file = argv$output, sep = "\t", quote = FALSE, - row.names = FALSE, na = "") +writeManifest(out, argv$output) cat(sprintf("Wrote manifest with %d row(s) (%d studies x %d regions) to %s\n", nrow(out), nrow(studies), nrow(regions), argv$output)) diff --git a/code/script/pecotmr_integration/gwas_rss_plot.R b/code/script/pecotmr_integration/gwas_rss_plot.R index aa1f5367b..9f8e4fc76 100644 --- a/code/script/pecotmr_integration/gwas_rss_plot.R +++ b/code/script/pecotmr_integration/gwas_rss_plot.R @@ -32,55 +32,39 @@ parser <- add_argument(parser, "--height", type = "numeric", default = 3) argv <- parse_args(parser) +write_empty <- function(msg) { + message(msg, "; writing an empty plot to ", argv$output) + dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) + ggsave(argv$output, ggplot() + theme_void() + labs(title = msg), + width = argv$width, height = argv$height, dpi = 150) +} + fmr <- readRDS(argv$input) if (!methods::is(fmr, "GwasFineMappingResult")) stop("--input must be a GwasFineMappingResult (got '", class(fmr)[[1L]], "').") if (nrow(fmr) == 0L) { - message("Empty GwasFineMappingResult; writing an empty plot to ", argv$output) - png(argv$output, width = argv$width * 100, height = argv$height * 100) - plot.new(); title(main = "No fine-mapping rows in input") - dev.off() + write_empty("No fine-mapping rows in input") quit(save = "no") } -# Build a tidy long table of (study, method, region_id, variant_id, pip) -# straight from the S4 accessors; one panel per row of the FMR. -panels <- lapply(seq_len(nrow(fmr)), function(i) { - entry <- fmr$entry[[i]] - pip <- as.numeric(getPip(entry)) - ids <- as.character(getVariantIds(entry)) - if (length(pip) == 0L || length(ids) == 0L) return(NULL) - data.frame( - study = as.character(fmr$study)[[i]], - method = as.character(fmr$method)[[i]], - region_id = as.character(fmr$region_id)[[i]], - variant_id = ids, - pip = pip, - stringsAsFactors = FALSE) -}) -panels <- panels[!vapply(panels, is.null, logical(1))] -if (length(panels) == 0L) { - message("No usable PIP vectors on any entry; writing an empty plot to ", - argv$output) - png(argv$output, width = argv$width * 100, height = argv$height * 100) - plot.new(); title(main = "No PIP vectors in input") - dev.off() +# One aggregated PIP table for the collection. getTopLoci(signalCutoff = 0) +# returns every variant with its decoded `pos` and the row-identity columns +# (study / method / region_id), so the panel label and position come straight +# off the table -- one panel per (study, method, region_id). +tl <- getTopLoci(fmr, signalCutoff = 0) +if (is.null(tl) || nrow(tl) == 0L) { + write_empty("No PIP vectors in input") quit(save = "no") } -df <- do.call(rbind, panels) - -# Extract a numeric pos when variant_id looks like "chrN:pos:..." or -# "chrN_pos_..."; otherwise plot against the row index. This is a -# best-effort cosmetic decode, not a hard requirement. -pos <- suppressWarnings({ - m <- regmatches(df$variant_id, - regexec("^[^:_]+[:_]([0-9]+)", df$variant_id)) - vapply(m, function(x) if (length(x) >= 2L) as.numeric(x[[2L]]) else NA_real_, - numeric(1L)) -}) -df$pos <- ifelse(is.na(pos), seq_len(nrow(df)), pos) -df$panel <- paste(df$study, df$method, df$region_id, sep = " | ") +pos <- suppressWarnings(as.numeric(tl$pos)) +pos[is.na(pos)] <- seq_len(nrow(tl))[is.na(pos)] +df <- data.frame( + variant_id = as.character(tl$variant_id), + pip = as.numeric(tl$pip), + pos = pos, + panel = paste(tl$study, tl$method, tl$region_id, sep = " | "), + stringsAsFactors = FALSE) g <- ggplot(df, aes(x = pos, y = pip)) + geom_point(alpha = 0.6, size = 0.8) + diff --git a/code/script/pecotmr_integration/gwas_sumstats_construct.R b/code/script/pecotmr_integration/gwas_sumstats_construct.R index 99cd7553f..1304c46db 100644 --- a/code/script/pecotmr_integration/gwas_sumstats_construct.R +++ b/code/script/pecotmr_integration/gwas_sumstats_construct.R @@ -57,11 +57,7 @@ suppressPackageStartupMessages({ library(argparser) library(pecotmr) - library(GenomicRanges) - library(IRanges) - library(S4Vectors) library(jsonlite) - library(yaml) }) parser <- arg_parser("Build a per-region (multi-study) GwasSumStats RDS") @@ -74,9 +70,17 @@ parser <- add_argument(parser, "--gwas-tsv", parser <- add_argument(parser, "--ld-block", help = "Analysis region as chr:start-end", type = "character") +parser <- add_argument(parser, "--ld-sketch", + help = paste("LD reference panel (ldSketch): a genome-wide genotype", + "prefix/path (.bed/.pgen/.vcf[.gz]/.bcf/.gds), OR a", + "per-chromosome mapping file with a chromosome column", + "and a 'path' column - one genotype payload per", + "chromosome (other columns, e.g. start/end, are", + "ignored). No sub-chromosomal block selection."), + type = "character", default = "") parser <- add_argument(parser, "--ld-meta", - help = "Path to LD-meta TSV", - type = "character") + help = "Deprecated alias for --ld-sketch (kept for backward compatibility).", + type = "character", default = "") parser <- add_argument(parser, "--genome", help = "Genome build label", type = "character", default = "GRCh38") @@ -195,161 +199,89 @@ if (length(skip_region_vec) == 0L) skip_region_vec <- NULL qc_method <- match.arg(argv$qc_method, c("none", "slalom", "dentist")) -parse_region <- function(s) { - m <- regmatches(s, regexec("^([^:]+):([0-9]+)-([0-9]+)$", s))[[1L]] - if (length(m) != 4L) - stop("--ld-block must be in chr:start-end format (got: ", s, ")") - list(chr = m[[2L]], start = as.integer(m[[3L]]), end = as.integer(m[[4L]])) -} - -block <- parse_region(argv$ld_block) - -# ----- Build the LD-reference GenotypeHandle spanning the region ------------ -# Resolve every LD-meta row overlapping the region and de-duplicate the -# genotype payloads. The one-file-per-chromosome layout (all overlapping -# rows share a prefix) gives a single handle that already covers the region; -# pecotmr's GenotypeHandle(ldMeta=…, region=…) round-trips the meta path as -# the data path (an upstream bug) and rejects multi-row regions, so we read -# the meta TSV ourselves and point a constructor at the resolved payload. -buildLdHandle <- function(ld_meta, block) { - ld_meta_dir <- dirname(normalizePath(ld_meta)) - ld_meta_df <- read.table(ld_meta, header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, - comment.char = "") - ld_chr_col <- intersect(c("#chr", "#chrom", "chr", "chrom"), - names(ld_meta_df))[1L] - if (is.na(ld_chr_col)) - stop("Could not find a chromosome column in ", ld_meta, - " (expected one of '#chr' / '#chrom' / 'chr' / 'chrom'); got: ", - paste(names(ld_meta_df), collapse = ", ")) - ld_chr_norm <- sub("^chr", "", as.character(ld_meta_df[[ld_chr_col]]), - ignore.case = TRUE) - block_chr_norm <- sub("^chr", "", block$chr, ignore.case = TRUE) - ld_start <- suppressWarnings(as.integer(ld_meta_df$start)) - ld_end <- suppressWarnings(as.integer(ld_meta_df$end)) - # `start = 0, end = 0` is the meta convention for "whole chromosome". - whole_chrom <- !is.na(ld_start) & !is.na(ld_end) & - ld_start == 0L & ld_end == 0L - # Strict overlap (no shared-endpoint match) so adjacent blocks that abut - # the region are not pulled in. - overlaps <- which(ld_chr_norm == block_chr_norm & - (whole_chrom | - (ld_start < block$end & ld_end > block$start))) - if (length(overlaps) == 0L) - stop("No LD-meta row overlaps ", argv$ld_block, " in ", ld_meta, ".") - ld_prefixes <- unique(ld_meta_df$path[overlaps]) - if (length(ld_prefixes) > 1L) - stop("Region ", argv$ld_block, " overlaps LD-meta rows pointing at ", - length(ld_prefixes), " distinct genotype payloads (", - paste(ld_prefixes, collapse = ", "), "). Multi-file LD merge is ", - "not supported here; restrict the region to a single payload.") - ld_prefix <- ld_prefixes[[1L]] - if (!startsWith(ld_prefix, "/")) - ld_prefix <- file.path(ld_meta_dir, ld_prefix) - - # Detect data format from companion file extensions. - if (file.exists(paste0(ld_prefix, ".pgen"))) { - GenotypeHandle(plink2Prefix = ld_prefix) - } else if (file.exists(paste0(ld_prefix, ".bed"))) { - GenotypeHandle(plink1Prefix = ld_prefix) - } else if (file.exists(paste0(ld_prefix, ".gds"))) { - GenotypeHandle(path = paste0(ld_prefix, ".gds")) - } else if (file.exists(paste0(ld_prefix, ".vcf.gz"))) { - GenotypeHandle(path = paste0(ld_prefix, ".vcf.gz")) - } else { - stop("Could not find a recognised genotype payload at LD-meta prefix: ", - ld_prefix, " (looked for .pgen / .bed / .gds / .vcf.gz)") - } -} - -ld_handle <- buildLdHandle(argv$ld_meta, block) - -# ----- Build one GwasSumStats entry GRanges per study ---------------------- -buildEntryGr <- function(gwas_tsv, mapping_path, block) { - column_mapping <- if (nzchar(mapping_path) && mapping_path != ".") { - if (!file.exists(mapping_path)) - stop("--column-mapping file not found: ", mapping_path) - yaml::read_yaml(mapping_path) - } else { - NULL - } - - gwas <- read.table(if (grepl("\\.gz$", gwas_tsv)) gzfile(gwas_tsv) - else gwas_tsv, - header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, - comment.char = "") - - pick <- function(opts, where) intersect(opts, names(where))[1L] - resolve_col <- function(std, fallback) { - if (!is.null(column_mapping) && !is.null(column_mapping[[std]])) { - named <- column_mapping[[std]] - if (!(named %in% names(gwas))) - stop("--column-mapping['", std, "'] = '", named, - "' is not a column in ", gwas_tsv) - return(named) - } - pick(fallback, gwas) - } - chr_col <- resolve_col("chrom", c("#chrom", "chrom", "chr")) - pos_col <- resolve_col("pos", c("pos", "position", "BP")) - snp_col <- resolve_col("variant_id", c("variant_id", "SNP", "rsid")) - a1_col <- resolve_col("A1", c("A1", "a1")) - a2_col <- resolve_col("A2", c("A2", "a2")) - z_col <- resolve_col("z", c("z", "Z")) - n_col <- resolve_col("n_sample", c("n_sample", "N", "n")) - - if (any(is.na(c(chr_col, pos_col, snp_col, a1_col, a2_col, z_col, n_col)))) - stop("--gwas-tsv missing one of required columns ", - "(chrom/pos/variant_id/A1/A2/z/n_sample) in: ", gwas_tsv, - if (!is.null(column_mapping)) - " — check that every required key is present in --column-mapping" - else "") - - # Normalise chromosome label to match the region's. - chrom_vals <- as.character(gwas[[chr_col]]) - if (!startsWith(chrom_vals[[1L]], "chr")) - chrom_vals <- paste0("chr", chrom_vals) - pos_vals <- as.integer(gwas[[pos_col]]) - keep <- chrom_vals == block$chr & pos_vals >= block$start & - pos_vals <= block$end - sub <- gwas[keep, , drop = FALSE] - if (nrow(sub) == 0L) - stop("No GWAS variants from ", gwas_tsv, " fall in region ", - argv$ld_block, " (after chromosome normalisation).") - - entry_gr <- GRanges( - seqnames = chrom_vals[keep], - ranges = IRanges(start = pos_vals[keep], width = 1L)) - mcols(entry_gr) <- DataFrame( - SNP = as.character(sub[[snp_col]]), - A1 = as.character(sub[[a1_col]]), - A2 = as.character(sub[[a2_col]]), - Z = as.numeric(sub[[z_col]]), - N = as.integer(sub[[n_col]])) - # Optional columns when present (hardcoded aliases). - for (slot in c("BETA", "SE", "P", "MAF", "INFO")) { - src <- intersect(c(slot, tolower(slot), - if (slot == "MAF") c("effect_allele_frequency"), - if (slot == "P") c("pvalue", "p")), - names(sub))[1L] - if (!is.na(src)) - mcols(entry_gr)[[slot]] <- as.numeric(sub[[src]]) - } - entry_gr +# ----- Resolve the LD sketch spec (genome-wide OR per-chromosome) ------------ +# LD sketches are never region/block-sharded: they are either a single +# genome-wide genotype file/prefix or one genotype file per chromosome. The raw +# --ld-sketch spec is handed straight to the loader's `ldSketch`, which sniffs a +# genotype path/prefix (-> genome-wide handle) versus a per-chromosome mapping +# file (-> genoMeta handle). In the mapping file the chromosome and path columns +# are matched by NAME (#chr/#chrom/chr/chrom + path/payload/prefix/genotype), so +# extra columns (e.g. legacy start/end) are tolerated, and each chromosome must +# map to exactly one payload (no sub-chromosomal blocks). +# The same ld-meta table may ALSO be cTWAS's LD-block grid (one row per block, +# many rows sharing a chromosome's single genotype panel). The sketch only cares +# about the genotype reference, so collapse a block-sharded table to its unique +# per-chromosome (chrom -> panel) mapping before handing it to the loader: the +# loader stays strict (one payload per chromosome) and the notebook can pass the +# block grid to both the block enumerator and the sketch with no separate +# fixture. A genotype path/prefix, or a table that is already one row per +# chromosome, is returned unchanged (the latter as an equivalent named vector). +.collapseSketchMeta <- function(spec) { + if (!(is.character(spec) && length(spec) == 1L)) return(spec) + lower <- tolower(spec) + if (grepl("\\.(pgen|bed|vcf(\\.b?gz)?|bcf|gds)$", lower) || + file.exists(paste0(spec, ".pgen")) || file.exists(paste0(spec, ".bed"))) + return(spec) # genotype file/prefix + if (!file.exists(spec) || dir.exists(spec)) return(spec) + meta <- tryCatch( + read.table(spec, header = TRUE, sep = "", comment.char = "", + stringsAsFactors = FALSE, check.names = FALSE), + error = function(e) NULL) + if (is.null(meta) || ncol(meta) < 2L) return(spec) + chromCol <- intersect(c("#chr", "#chrom", "chr", "chrom"), names(meta))[1L] + pathCol <- intersect(c("path", "payload", "prefix", "genotype"), names(meta))[1L] + if (is.na(chromCol) || is.na(pathCol)) return(spec) # not a chrom->path table + base <- dirname(normalizePath(spec)) + chrom <- as.character(meta[[chromCol]]) + pth <- as.character(meta[[pathCol]]) + pth <- vapply(pth, function(p) + if (grepl("^(/|[A-Za-z]:)", p) || file.exists(p)) p else file.path(base, p), + character(1), USE.NAMES = FALSE) + keep <- !duplicated(paste(chrom, pth, sep = "\t")) + chrom <- chrom[keep]; pth <- pth[keep] + if (anyDuplicated(chrom)) + stop("--ld-sketch '", spec, "': chromosome(s) ", + paste(unique(chrom[duplicated(chrom)]), collapse = ", "), + " map to multiple genotype payloads; each chromosome must reference ", + "exactly one LD panel.") + # A single genotype panel (one chromosome / one shared payload) is returned as + # the bare prefix so the GenotypeHandle keeps a real on-disk @path -- cTWAS's + # .ctwasLdPanelKey resolves the LD file from it. Only a genuinely multi-panel + # per-chromosome reference needs the named chrom->path vector. + if (length(pth) == 1L) return(unname(pth)) + stats::setNames(pth, chrom) } +ld_sketch_spec <- if (nzchar(argv$ld_sketch)) argv$ld_sketch else argv$ld_meta +if (!nzchar(ld_sketch_spec)) + stop("--ld-sketch is required (the LD reference panel for the ldSketch).") +ld_sketch_spec <- .collapseSketchMeta(ld_sketch_spec) -entries <- lapply(seq_along(studies), function(k) - buildEntryGr(gwasTsvs[[k]], mappings[[k]], block)) +# ----- Build the GwasSumStats via pecotmr's manifest loader ----------------- +# Assemble an in-memory one-row-per-study manifest and hand it to +# loadGwasSumStatsFromManifest(), which reads each sumstats file, resolves the +# columns (its built-in aliases match the hardcoded set this script used, plus +# per-study columnMapping YAML), reconciles chr-prefix conventions, restricts +# to `region`, and constructs the GwasSumStats. The raw LD-sketch spec is passed +# through as `ldSketch` (a genotype path/prefix -> genome-wide handle, or a +# per-chromosome mapping file -> genoMeta handle; resolved inside the loader). +# +# NOTE: region restriction of delimited-text sumstats now requires a +# `.tbi` tabix sidecar; a non-indexed TSV is read whole (with a warning). +# The pipeline's GWAS sumstats are bgzipped + tabix-indexed. +manifest_df <- data.frame( + study = studies, + sumStatsPath = gwasTsvs, + stringsAsFactors = FALSE) +if (any(nzchar(mappings))) + manifest_df$columnMapping <- ifelse(nzchar(mappings), mappings, NA_character_) +if (!is.null(nCase)) manifest_df$nCase <- nCase +if (!is.null(nControl)) manifest_df$nControl <- nControl -# ----- Construct + QC + save ------------------------------------------------ -gss <- GwasSumStats( - study = studies, - entry = entries, +gss <- loadGwasSumStatsFromManifest( + manifest = manifest_df, genome = argv$genome, - ldSketch = ld_handle, - nCase = nCase, - nControl = nControl) + ldSketch = ld_sketch_spec, + region = argv$ld_block) gss_out <- if (argv$skip_qc) { message("--skip-qc set; serialising raw GwasSumStats without summaryStatsQc().") gss diff --git a/code/script/pecotmr_integration/legacy_ctwas_weights_to_s4.R b/code/script/pecotmr_integration/legacy_ctwas_weights_to_s4.R deleted file mode 100644 index 9394f93f8..000000000 --- a/code/script/pecotmr_integration/legacy_ctwas_weights_to_s4.R +++ /dev/null @@ -1,157 +0,0 @@ -#!/usr/bin/env Rscript -# legacy_ctwas_weights_to_s4.R -# -# One-shot extractor: legacy `*.ctwas_weights.*.rds` (the OUTPUT of the -# legacy [ctwas_1] step) into the new S4 `pecotmr::TwasWeights` shape. -# -# Why this exists: the legacy MWE ships -# `protocol_example.ctwas_weights.protocol_example_twas_chr22.chr22.rds` -# with strong weights (max|w| ≈ 1.35) that demonstrably drive ctwas to -# the documented gene-Z = 5.46 result, BUT those weights are not -# reproducible from the upstream `.reshaped_toy.rds` via the documented -# pipeline (the legacy code path produces ~1e-5 values, not ~1e-0). -# The legacy `ctwas_weights.rds` therefore appears to come from a -# stronger upstream fit that isn't shipped. To smoke-test our new -# `ctwasPipeline` end-to-end with default thresholds, we extract those -# already-on-correlation-scale weights into an S4 TwasWeights so the -# pipeline sees the same numerical input the legacy ctwas_3 step did. -# -# The extracted weights are STANDARDIZED (already on the correlation -# scale — the legacy multiplied by sqrt(variance) when building the -# file), so the resulting TwasWeightsEntry carries `standardized = TRUE` -# and our `.ctwasBuildWeights` will skip the sqrt(variance) scaling. -# -# Usage: -# Rscript legacy_ctwas_weights_to_s4.R \ -# --legacy \ -# --study \ -# --method (default "susie") -# --ld-meta --ld-block (or --ld-prefix) -# --output - -suppressPackageStartupMessages({ - library(argparser) - library(pecotmr) -}) - -parser <- arg_parser("Convert legacy ctwas_weights.rds to S4 TwasWeights") -parser <- add_argument(parser, "--legacy", - help = "Path to legacy *.ctwas_weights.*.rds", - type = "character") -parser <- add_argument(parser, "--study", - help = "Study label to stamp on every entry", - type = "character") -parser <- add_argument(parser, "--method", - help = "Method label to stamp on every entry (default 'susie')", - type = "character", default = "susie") -parser <- add_argument(parser, "--ld-meta", - help = "LD-meta TSV path (used with --ld-block)", - type = "character", default = "") -parser <- add_argument(parser, "--ld-block", - help = "LD block as chr:start-end (with --ld-meta)", - type = "character", default = "") -parser <- add_argument(parser, "--ld-prefix", - help = "Explicit LD prefix (bypasses LD-meta lookup)", - type = "character", default = "") -parser <- add_argument(parser, "--output", - help = "Output RDS path", type = "character") -argv <- parse_args(parser) - -resolve_ld_prefix <- function(meta_path, block_str) { - m <- regmatches(block_str, regexec("^([^:]+):([0-9]+)-([0-9]+)$", block_str))[[1L]] - if (length(m) != 4L) - stop("--ld-block must be chr:start-end (got: ", block_str, ")") - block <- list(chr = m[[2L]], start = as.integer(m[[3L]]), - end = as.integer(m[[4L]])) - meta_dir <- dirname(normalizePath(meta_path)) - meta <- read.table(meta_path, header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, - comment.char = "") - chr_col <- intersect(c("#chr", "#chrom", "chr", "chrom"), names(meta))[1L] - chr_norm <- sub("^chr", "", as.character(meta[[chr_col]]), ignore.case = TRUE) - block_norm <- sub("^chr", "", block$chr, ignore.case = TRUE) - s <- suppressWarnings(as.integer(meta$start)) - e <- suppressWarnings(as.integer(meta$end)) - whole <- !is.na(s) & !is.na(e) & s == 0L & e == 0L - hit <- which(chr_norm == block_norm & - (whole | (s <= block$start & e >= block$end))) - if (length(hit) != 1L) - stop("LD-meta lookup for ", block_str, " returned ", length(hit), " rows.") - pfx <- meta$path[hit] - if (!startsWith(pfx, "/")) pfx <- file.path(meta_dir, pfx) - pfx -} - -open_handle <- function(prefix) { - if (file.exists(paste0(prefix, ".pgen"))) GenotypeHandle(plink2Prefix = prefix) - else if (file.exists(paste0(prefix, ".bed"))) GenotypeHandle(plink1Prefix = prefix) - else if (file.exists(paste0(prefix, ".gds"))) GenotypeHandle(path = paste0(prefix, ".gds")) - else if (file.exists(paste0(prefix, ".vcf.gz"))) GenotypeHandle(path = paste0(prefix, ".vcf.gz")) - else stop("No genotype payload at LD prefix: ", prefix) -} - -ld_handle <- if (nzchar(argv$ld_prefix)) { - open_handle(argv$ld_prefix) -} else if (nzchar(argv$ld_meta) && nzchar(argv$ld_block)) { - open_handle(resolve_ld_prefix(argv$ld_meta, argv$ld_block)) -} else { - stop("Provide either --ld-prefix or (--ld-meta AND --ld-block).") -} - -# --- Walk the legacy structure and build TwasWeightsEntry per gene ---- -legacy <- readRDS(argv$legacy) -if (!is.list(legacy) || length(legacy) == 0L) - stop("Legacy ctwas_weights RDS is empty or not a list: ", argv$legacy) - -studies <- character(0) -contexts <- character(0) -traits <- character(0) -methods <- character(0) -entries <- list() - -# Legacy keys: "|_"; values are a list with -# wgt (variants × 1 matrix), molecular_id, type, context, etc. -for (gene_key in names(legacy)) { - entry_obj <- legacy[[gene_key]] - if (!is.list(entry_obj) || is.null(entry_obj$wgt)) next - wgt_mat <- entry_obj$wgt - if (nrow(wgt_mat) == 0L) next - - vids <- rownames(wgt_mat) - wvec <- as.numeric(wgt_mat[, 1L]) - - trait <- entry_obj$molecular_id %||% sub("\\|.*$", "", gene_key) - ctx_label <- entry_obj$context %||% sub("^.*\\|", "", gene_key) - - weights_one_col <- matrix(wvec, ncol = 1L, - dimnames = list(vids, argv$method)) - - tw_entry <- TwasWeightsEntry( - variantIds = vids, - weights = weights_one_col, - # Already on the correlation scale (legacy multiplied by - # sqrt(variance)); skip the sqrt(variance) step downstream. - standardized = TRUE) - - studies <- c(studies, argv$study) - contexts <- c(contexts, ctx_label) - traits <- c(traits, trait) - methods <- c(methods, argv$method) - entries <- c(entries, list(tw_entry)) -} - -if (length(entries) == 0L) - stop("Converter produced 0 entries from ", argv$legacy) - -tw <- TwasWeights( - study = studies, - context = contexts, - trait = traits, - method = methods, - entry = entries, - ldSketch = ld_handle) - -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -saveRDS(tw, argv$output) -cat(sprintf("Wrote S4 TwasWeights (%d entries; %d unique traits) to %s\n", - length(entries), length(unique(traits)), argv$output)) diff --git a/code/script/pecotmr_integration/legacy_enloc_finemap_convert.R b/code/script/pecotmr_integration/legacy_enloc_finemap_convert.R deleted file mode 100644 index 41c3c04bf..000000000 --- a/code/script/pecotmr_integration/legacy_enloc_finemap_convert.R +++ /dev/null @@ -1,346 +0,0 @@ -#!/usr/bin/env Rscript -# legacy_enloc_finemap_convert.R -# -# Bridge for migrating the legacy SuSiE-enloc fine-mapping RDS files to the -# new pecotmr S4 path, so the enrichment + coloc cells of SuSiE_enloc.ipynb -# can call qtl_enrichment.R / coloc.R (which consume S4 -# QtlFineMappingResult / GwasFineMappingResult collections). -# -# Two modes, each emitting ONE combined collection RDS: -# --mode qtl : a QtlFineMappingResult spanning every (study, context) -# fit found in the per-study `*.univariate_susie_twas_weights.rds` -# files (one entry per (study, context, trait=gene, method="susie")). -# --mode gwas : a GwasFineMappingResult spanning every (gwas_study, block) -# fit found in the per-block `*.univariate_susie_rss.rds` files -# (one entry per (gwas_study, region_id=block, method="susie_rss")). -# -# Legacy inner shape (shared by both modes), per fit: -# $variant_names all variant ids (e.g. "chr1:20520132:G:C" for qtl, -# "1:17351816:A:C" for gwas), one per column of the fit. -# $susie_result_trimmed a SuSiE object: $pip (over all variants, UNNAMED), -# $sets ($cs list of per-effect variant-index vectors, -# NULL when no credible set), $alpha / $mu / $mu2 / -# $lbf_variable (L x nvariants), $V (per-effect prior -# variance). -# $top_loci a small canonical-top-loci df (NOT used here; we -# build topLoci over ALL variants so getTopLoci's -# posterior projection has the full per-variant view). -# $sumstats betahat/sebetahat (qtl) over all variants (UNNAMED, -# aligned by index to variant_names); GWAS carries z. -# -# qtl files: RDS[[gene]][[context]] = inner -# gwas files: RDS[[block]][[gwas_study]]$RSS_QC_RAISS_imputed = inner -# (some [[block]][[gwas_study]] are empty list() -> skipped) -# -# FIELD-MAPPING into the canonical topLoci (consumed via getTopLoci / -# .projectPosteriorView, which sources variant_id/chrom/pos/A1/A2, pip, -# beta<-posterior_mean, se<-posterior_sd, and passes cs_95 through): -# variant_id <- variant_names (verbatim; chr-prefix convention preserved; -# colocPipeline/qtlEnrichmentPipeline reconcile qtl vs gwas -# conventions via alignVariantNames) -# chrom/pos/A1/A2 <- parsed from chr:pos:A1:A2 -# pip <- susie_result_trimmed$pip (set as names on the fit too, -# so the FineMappingEntry drift check passes) -# posterior_mean <- colSums(alpha * mu) [proper SuSiE posterior] -# posterior_sd <- sqrt(pmax(colSums(alpha*mu2) - posterior_mean^2, 0)) -# cs_95 <- "L" for variants in credible set k, "0" otherwise -# (from susie_result_trimmed$sets$cs; "0" everywhere when NULL) -# susieFit is kept as the full susie_result_trimmed (coloc needs lbf_variable/ -# sets/V; enrichment needs alpha/pip/V). -# -# LD-SKETCH: the QtlFineMappingResult is emitted with ldSketch = NULL -# (individual-level fits). The GwasFineMappingResult MUST carry a non-NULL -# GenotypeHandle ldSketch -- qtlEnrichmentPipeline hard-requires it -- so a -# minimal placeholder GenotypeHandle is attached. It is never inspected for -# content: .requireMatchingLdSketches short-circuits the moment the QTL side -# is NULL, so no real genotype panel is needed for this MWE bridge. -# -# OBJECT PATHS: the fit / variant-names live at configurable nested paths -# inside `inner` (qtl) or `rds[[block]]` (gwas), supplied via --finemapping-obj -# / --varname-obj (each a single string of space-separated path components). -# QTL : inner = rds[[gene]][[context]]; the obj path is applied to `inner`, -# e.g. "preset_variants_result susie_result_trimmed" reaches the legacy -# PRESET-subset fit (NOT inner$susie_result_trimmed, the full fit). -# GWAS : the obj's FIRST element is the specific GWAS study; the WHOLE path is -# applied to rds[[block]], e.g. -# "AD_Bellenguez_2022 RSS_QC_RAISS_imputed susie_result_trimmed" -# reaches that one study's fit. The GwasFMR study label = obj[[1]]. -# -# Inputs: -# --mode {qtl, gwas} -# --meta xqtl_meta tsv (qtl mode) or gwas_meta tsv (gwas mode); used to -# discover the per-study/per-block RDS basenames + labels. When -# absent / unreadable the converter falls back to globbing -# --data-dir for the matching RDS pattern. -# --data-dir directory holding the legacy RDS files (and the meta tsv) -# --rds-files comma-separated explicit RDS paths; when given, bypasses -# --meta/--data-dir discovery and uses exactly those files -# (per-region mode). -# --finemapping-obj space-separated path to the fit inside inner (qtl) or -# rds[[block]] (gwas; first component = study). Defaults to the -# verified legacy QTL/GWAS paths when empty. -# --varname-obj space-separated path to the variant_names vector. -# --region-obj space-separated path to the region grange (accepted for -# CLI parity with the legacy interface; not consumed here). -# --method fine-mapping method label (default: susie for qtl, susie_rss for gwas) -# --output output collection RDS - -suppressPackageStartupMessages({ library(argparser); library(pecotmr) }) - -p <- arg_parser("Convert legacy SuSiE-enloc fine-mapping RDS to pecotmr S4") -p <- add_argument(p, "--mode", type = "character", - help = "qtl or gwas") -p <- add_argument(p, "--meta", type = "character", default = "", - help = "xqtl_meta / gwas_meta tsv (optional; else glob --data-dir)") -p <- add_argument(p, "--data-dir", type = "character", default = "", - help = "directory of the legacy *.rds files") -p <- add_argument(p, "--rds-files", type = "character", default = "", - help = "comma-separated explicit RDS paths (per-region; bypasses --meta/--data-dir)") -p <- add_argument(p, "--finemapping-obj", type = "character", default = "", - help = "space-separated object path to the fit (default: verified legacy path)") -p <- add_argument(p, "--varname-obj", type = "character", default = "", - help = "space-separated object path to variant_names (default: verified legacy path)") -p <- add_argument(p, "--region-obj", type = "character", default = "", - help = "space-separated object path to region grange (CLI parity; unused here)") -p <- add_argument(p, "--study", type = "character", default = "", - help = "QTL study label override (default: parsed from filename)") -p <- add_argument(p, "--method", type = "character", default = "", - help = "method label (default susie [qtl] / susie_rss [gwas])") -p <- add_argument(p, "--output", type = "character", - help = "output collection RDS") -argv <- parse_args(p) - -mode <- match.arg(argv$mode, c("qtl", "gwas")) -method <- if (nzchar(argv$method)) argv$method else - if (mode == "qtl") "susie" else "susie_rss" - -# Parse a single space-separated CLI string into a character path vector. -parseObjPath <- function(x) { - if (is.null(x) || !nzchar(trimws(x))) return(character(0)) - strsplit(trimws(x), "\\s+")[[1L]] -} - -# Object paths into the RDS -- REQUIRED, supplied by the caller (the SoS cell -# forwards the legacy --*-finemapping-obj / --*-varname-obj values). They are -# deliberately NOT defaulted: the fit / variant-name locations are a property of -# the input data, not of this script, so hardcoding them here would silently -# bind the converter to one dataset's layout. For GWAS the first path element is -# the study (which becomes the GwasFMR study label). -finemappingObj <- parseObjPath(argv$finemapping_obj) -varnameObj <- parseObjPath(argv$varname_obj) -if (length(finemappingObj) == 0L) - stop("--finemapping-obj is required (space-separated object path to the fit).") -if (length(varnameObj) == 0L) - stop("--varname-obj is required (space-separated object path to variant_names).") - -# ---- shared helpers -------------------------------------------------------- - -# Walk a nested list `x` along the character path components in `path`. An empty -# / NULL path returns `x` unchanged; a missing intermediate short-circuits NULL. -getNested <- function(x, path) { - if (is.null(path) || length(path) == 0L) return(x) - for (p in path) { - if (is.null(x)) return(NULL) - x <- x[[p]] - } - x -} - -# Parse "chr:pos:A1:A2" ids into the canonical identity columns. Tolerant of a -# missing "chr" prefix (gwas ids) and of malformed ids (NA-filled). -parseIds <- function(vids) { - vp <- strsplit(as.character(vids), ":", fixed = TRUE) - g <- function(i) vapply(vp, function(x) - if (length(x) >= i) x[[i]] else NA_character_, character(1)) - list(chrom = sub("^chr", "", g(1L)), - pos = suppressWarnings(as.integer(g(2L))), - A1 = g(3L), - A2 = g(4L)) -} - -# Per-variant posterior mean / sd from a (trimmed) SuSiE fit's single-effect -# matrices: E[b] = sum_l alpha_lj mu_lj ; Var[b] = sum_l alpha_lj mu2_lj - E[b]^2. -# Falls back to 0 / a small placeholder when the matrices are unavailable. -posteriorMeanSd <- function(fit, n) { - alpha <- if (!is.null(fit$alpha)) as.matrix(fit$alpha) else NULL - mu <- if (!is.null(fit$mu)) as.matrix(fit$mu) else NULL - mu2 <- if (!is.null(fit$mu2)) as.matrix(fit$mu2) else NULL - if (!is.null(alpha) && !is.null(mu) && all(dim(alpha) == dim(mu)) && - ncol(alpha) == n) { - pm <- as.numeric(colSums(alpha * mu)) - ps <- if (!is.null(mu2) && all(dim(alpha) == dim(mu2))) - as.numeric(sqrt(pmax(colSums(alpha * mu2) - pm^2, 0))) - else pmax(abs(pm) * 0.5, 0.05) - return(list(mean = pm, sd = ps)) - } - list(mean = rep(0, n), sd = rep(0.05, n)) -} - -# Credible-set membership label per variant: "L" for variants in the k-th -# credible set of susie_result_trimmed$sets$cs, "0" otherwise. Index vectors in -# $sets$cs are 1-based positions into the variant axis. -csLabels <- function(fit, n) { - out <- rep("0", n) - cs <- fit$sets$cs - if (is.null(cs) || length(cs) == 0L) return(out) - csNames <- names(cs) - for (k in seq_along(cs)) { - idx <- cs[[k]] - idx <- idx[!is.na(idx) & idx >= 1L & idx <= n] - if (length(idx) == 0L) next - lab <- if (!is.null(csNames) && nzchar(csNames[[k]])) csNames[[k]] - else paste0("L", k) - out[idx] <- lab - } - out -} - -# Build one FineMappingEntry from a legacy inner fit list. The fit and its -# variant-names are sourced via configurable object paths (relative to `inner`). -buildEntry <- function(inner, finemappingObj, varnameObj) { - fit <- getNested(inner, finemappingObj) - vids <- as.character(getNested(inner, varnameObj)) - n <- length(vids) - if (is.null(fit) || is.null(fit$pip) || n == 0L) return(NULL) - pip <- as.numeric(fit$pip) - if (length(pip) != n) return(NULL) - names(fit$pip) <- vids # name the fit's pip (drift check + pipelines) - pms <- posteriorMeanSd(fit, n) - ids <- parseIds(vids) - topLoci <- data.frame( - variant_id = vids, - chrom = ids$chrom, - pos = ids$pos, - A1 = ids$A1, - A2 = ids$A2, - pip = pip, - posterior_mean = pms$mean, - posterior_sd = pms$sd, - cs_95 = csLabels(fit, n), - stringsAsFactors = FALSE) - FineMappingEntry(variantIds = vids, susieFit = fit, topLoci = topLoci) -} - -# Discover the basenames of the legacy RDS to read, preferring the meta tsv's -# `original_data` column (comma-separated), falling back to a directory glob. -discoverFiles <- function(meta, dataDir, pattern) { - files <- character(0) - if (nzchar(meta) && file.exists(meta)) { - md <- tryCatch( - utils::read.delim(meta, header = TRUE, sep = "\t", - check.names = FALSE, comment.char = "", - stringsAsFactors = FALSE), - error = function(e) NULL) - if (!is.null(md) && "original_data" %in% colnames(md)) { - bn <- unlist(strsplit(as.character(md$original_data), ",", fixed = TRUE)) - bn <- trimws(bn[nzchar(trimws(bn))]) - files <- file.path(dataDir, unique(bn)) - files <- files[file.exists(files)] - } - } - if (length(files) == 0L) { - files <- list.files(dataDir, pattern = pattern, full.names = TRUE) - } - unique(files) -} - -# ---- QTL mode -------------------------------------------------------------- -# RDS[[gene]][[context]] = inner. study label comes from --study (the SoS cell -# forwards ${name}); context = the inner key, trait = the gene. The fit/varname -# obj paths are the tail applied to `inner`. -convertQtl <- function(files, finemappingObj, varnameObj, studyOverride = "") { - if (!nzchar(studyOverride)) - stop("--study is required in QTL mode (the study label is a property of ", - "the analysis, not encoded generically in the filename).") - fs <- character(0); fc <- character(0); ft <- character(0) - fm <- character(0); fe <- list() - for (f in files) { - study <- studyOverride - rds <- readRDS(f) - for (gene in names(rds)) { - for (context in names(rds[[gene]])) { - entry <- buildEntry(rds[[gene]][[context]], finemappingObj, varnameObj) - if (is.null(entry)) next - fe[[length(fe) + 1L]] <- entry - fs <- c(fs, study); fc <- c(fc, context) - ft <- c(ft, gene); fm <- c(fm, method) - } - } - } - if (length(fe) == 0L) stop("No QTL fine-mapping entries built from inputs.") - QtlFineMappingResult(study = fs, context = fc, trait = ft, - method = fm, entry = fe, ldSketch = NULL) -} - -# ---- GWAS mode ------------------------------------------------------------- -# RDS[[block]] holds per-study nodes. The obj's FIRST element is the specific -# GWAS study; the WHOLE obj path applied to rds[[block]] reaches that one -# study's fit (getNested(rds[[block]], gwasObj)). study = obj[[1]], region_id = -# block. We iterate blocks (files) for that one study, skipping empty nodes. -convertGwas <- function(files, finemappingObj, varnameObj) { - gwasStudy <- finemappingObj[[1L]] - fitTail <- finemappingObj[-1L] # path inside rds[[block]][[study]] - varTail <- varnameObj[-1L] - gs <- character(0); gm <- character(0); gr <- character(0); ge <- list() - for (f in files) { - rds <- readRDS(f) - for (block in names(rds)) { - node <- rds[[block]][[gwasStudy]] - if (is.null(node) || length(node) == 0L) next # empty study in block - entry <- buildEntry(node, fitTail, varTail) - if (is.null(entry)) next - ge[[length(ge) + 1L]] <- entry - gs <- c(gs, gwasStudy); gm <- c(gm, method); gr <- c(gr, block) - } - } - if (length(ge) == 0L) stop("No GWAS fine-mapping entries built from inputs.") - # qtlEnrichmentPipeline hard-requires a non-NULL GenotypeHandle ldSketch on - # the GWAS side. It is never inspected for content here (the matching check - # short-circuits because the QTL ldSketch is NULL), so a minimal placeholder - # handle suffices for this MWE bridge. - ldSketch <- new("GenotypeHandle", - path = "", - format = "vcf", - snpInfo = data.frame(SNP = character(0), CHR = character(0), - BP = integer(0), A1 = character(0), - A2 = character(0), - stringsAsFactors = FALSE), - nSamples = 0L, sampleIds = character(0), - pgenPtr = NULL, chromPaths = character(0)) - GwasFineMappingResult(study = gs, method = gm, entry = ge, - region_id = gr, ldSketch = ldSketch) -} - -# ---- dispatch -------------------------------------------------------------- -# Per-region mode: --rds-files lists exactly which RDS to read (bypasses the -# whole-collection --meta/--data-dir discovery). Otherwise discover via meta/glob. -if (nzchar(trimws(argv$rds_files))) { - files <- trimws(strsplit(argv$rds_files, ",", fixed = TRUE)[[1L]]) - files <- files[nzchar(files)] - missing <- files[!file.exists(files)] - if (length(missing) > 0L) - stop("These --rds-files do not exist: ", paste(missing, collapse = ", ")) -} else { - pattern <- if (mode == "qtl") { - "univariate_susie_twas_weights\\.rds$" - } else { - "univariate_susie_rss\\.rds$" - } - files <- discoverFiles(argv$meta, argv$data_dir, pattern) -} -if (length(files) == 0L) - stop("No legacy RDS files found (rds-files='", argv$rds_files, "', meta='", - argv$meta, "', data-dir='", argv$data_dir, "').") -cat(sprintf("[%s mode] reading %d legacy RDS file(s)\n", mode, length(files))) - -res <- if (mode == "qtl") { - convertQtl(files, finemappingObj, varnameObj, argv$study) -} else { - convertGwas(files, finemappingObj, varnameObj) -} - -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -saveRDS(res, argv$output) -cat(sprintf("Wrote %s (%d entries) to %s\n", - class(res)[[1L]], nrow(res), argv$output)) -print(res) diff --git a/code/script/pecotmr_integration/legacy_twas_weights_convert.R b/code/script/pecotmr_integration/legacy_twas_weights_convert.R deleted file mode 100644 index a17792da1..000000000 --- a/code/script/pecotmr_integration/legacy_twas_weights_convert.R +++ /dev/null @@ -1,118 +0,0 @@ -#!/usr/bin/env Rscript -# legacy_twas_weights_convert.R -# -# Bridge for migrating legacy TWAS analyses to the new pecotmr S4 path: convert -# a legacy `*.univariate_twas_weights.rds` (the nested list a legacy -# load_twas_weights() consumed: gene > context > {twas_weights, twas_cv_result, -# susie_weights_intermediate, variant_names, region_info, ...}) into: -# -# * a pecotmr::TwasWeights S4 RDS (one row per (study, context, trait, -# method); cvPerformance carried over so causalInferencePipeline's -# rsqCutoff weight-selection works), and -# * optionally a pecotmr::QtlFineMappingResult S4 RDS built from the SuSiE -# intermediate fit, so causalInferencePipeline can run MR. -# -# The pair is the input contract of twas.R (--twas-weights / --fine-mapping-result). -# -# CAVEAT (FMR): the legacy SuSiE intermediate fit carries pip + the coefficient -# (used as the per-variant QTL effect, topLoci$posterior_mean) but NO marginal -# standard error, so topLoci$posterior_sd is a magnitude-scaled placeholder. MR -# is only run by causalInferencePipeline for TWAS-significant tuples -# (mrPvalCutoff gate), so this placeholder only matters for genes that pass it. -# -# Inputs: -# --legacy Legacy univariate_twas_weights.rds -# --study Study identifier for the emitted rows -# --output Output TwasWeights RDS -# --output-fmr Optional output QtlFineMappingResult RDS (from the SuSiE fit) - -suppressPackageStartupMessages({ library(argparser); library(pecotmr) }) - -p <- arg_parser("Convert a legacy univariate_twas_weights.rds to pecotmr S4") -p <- add_argument(p, "--legacy", type = "character", - help = "legacy univariate_twas_weights.rds") -p <- add_argument(p, "--study", type = "character", default = "study", - help = "study identifier for the emitted rows") -p <- add_argument(p, "--output", type = "character", - help = "output TwasWeights RDS") -p <- add_argument(p, "--output-fmr", type = "character", default = "", - help = "optional output QtlFineMappingResult RDS (from the SuSiE fit)") -argv <- parse_args(p) - -legacy <- readRDS(argv$legacy) - -# Legacy per-method CV performance (1 x 6 matrix: corr,rsq,adj_rsq,pval,RMSE,MAE) -# -> the new cvPerformance shape list(metrics = named vector). -perfToCv <- function(perf) { - if (is.null(perf)) return(NULL) - v <- as.numeric(perf) - nms <- colnames(perf) - if (is.null(nms) || length(nms) != length(v)) - nms <- c("corr", "rsq", "adj_rsq", "pval", "RMSE", "MAE")[seq_along(v)] - list(metrics = stats::setNames(v, nms)) -} - -# ---- TwasWeights ----------------------------------------------------------- -rs <- character(0); rc <- character(0); rt <- character(0) -rm <- character(0); entries <- list() -for (trait in names(legacy)) { - for (ctxKey in names(legacy[[trait]])) { - inner <- legacy[[trait]][[ctxKey]] - context <- sub(paste0("_", trait, "$"), "", ctxKey) # bulk_rnaseq_ENSG... -> bulk_rnaseq - perfL <- inner$twas_cv_result$performance - for (wnm in names(inner$twas_weights)) { - tok <- sub("_weights$", "", wnm) # susie_weights -> susie - wmat <- inner$twas_weights[[wnm]] - vids <- if (!is.null(rownames(wmat))) rownames(wmat) else inner$variant_names - wvec <- stats::setNames(as.numeric(wmat), vids) - cv <- perfToCv(perfL[[paste0(tok, "_performance")]]) - entries[[length(entries) + 1L]] <- TwasWeightsEntry( - variantIds = vids, weights = wvec, cvResult = cv, - standardized = FALSE, dataType = context) - rs <- c(rs, argv$study); rc <- c(rc, context) - rt <- c(rt, trait); rm <- c(rm, tok) - } - } -} -tw <- TwasWeights(study = rs, context = rc, trait = rt, method = rm, entry = entries) -saveRDS(tw, argv$output) -cat(sprintf("Wrote TwasWeights (%d rows: %s) to %s\n", - nrow(tw), paste(unique(rm), collapse = ","), argv$output)) - -# ---- QtlFineMappingResult from the SuSiE intermediate fit (optional) ------- -if (nzchar(argv$output_fmr)) { - fs <- character(0); fc <- character(0); ft <- character(0) - fm <- character(0); fe <- list() - for (trait in names(legacy)) { - for (ctxKey in names(legacy[[trait]])) { - inner <- legacy[[trait]][[ctxKey]] - context <- sub(paste0("_", trait, "$"), "", ctxKey) - s <- inner$susie_weights_intermediate - if (is.null(s) || is.null(s$pip)) next - vids <- names(s$pip) - sw <- inner$twas_weights[["susie_weights"]] - bx <- as.numeric(sw)[match(vids, rownames(sw))]; bx[is.na(bx)] <- 0 - sx <- pmax(abs(bx) * 0.5, 0.05) # placeholder SE (legacy fit has none) - # getTopLoci()/.projectPosteriorView re-derives variant_id from - # chrom:pos:A1:A2 and sources beta<-posterior_mean, se<-posterior_sd, so - # supply those identity + effect columns under the canonical names. - vp <- strsplit(vids, ":", fixed = TRUE) - g <- function(i) vapply(vp, function(x) - if (length(x) >= i) x[[i]] else NA_character_, character(1)) - topLoci <- data.frame( - variant_id = vids, chrom = g(1L), - pos = suppressWarnings(as.integer(g(2L))), A1 = g(3L), A2 = g(4L), - pip = as.numeric(s$pip), posterior_mean = bx, posterior_sd = sx, - stringsAsFactors = FALSE) - fe[[length(fe) + 1L]] <- FineMappingEntry( - variantIds = vids, susieFit = s, topLoci = topLoci) - fs <- c(fs, argv$study); fc <- c(fc, context) - ft <- c(ft, trait); fm <- c(fm, "susie") - } - } - fmr <- QtlFineMappingResult(study = fs, context = fc, trait = ft, - method = fm, entry = fe) - saveRDS(fmr, argv$output_fmr) - cat(sprintf("Wrote QtlFineMappingResult (%d rows) to %s\n", - nrow(fmr), argv$output_fmr)) -} diff --git a/code/script/pecotmr_integration/manifest_common.R b/code/script/pecotmr_integration/manifest_common.R new file mode 100644 index 000000000..59074475b --- /dev/null +++ b/code/script/pecotmr_integration/manifest_common.R @@ -0,0 +1,88 @@ +# manifest_common.R +# +# Shared helpers for the pecotmr_integration MANIFEST wrapper scripts +# (region_manifest / gwas_rss_manifest / ctwas_manifest / twas_manifest / +# enloc_manifest / colocboost_manifest / mash_manifest / ld_blocks_to_manifest). +# Each script sources this from its own directory: +# +# .d <- dirname(sub("^--file=", "", +# grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +# source(file.path(.d, "manifest_common.R")) +# +# These are I/O + orchestration utilities only (no analysis logic -- that lives +# in pecotmr). All table I/O goes through readr for consistency; the reader +# wrappers reproduce the base-R read.table semantics the scripts relied on +# (all-character columns, `#chr` header kept verbatim, only the literal "NA" +# treated as missing, no whitespace trimming, `#`-comment handling per caller). + +suppressPackageStartupMessages(library(readr)) + +# ---- table I/O -------------------------------------------------------------- + +# Header TSV -> data.frame, every column character, column names kept verbatim +# (so `#chr` survives). Matches read.table(header=TRUE, sep="\t", quote="", +# comment.char="", check.names=FALSE, stringsAsFactors=FALSE, na.strings="NA", +# strip.white=FALSE). +readMeta <- function(path) + as.data.frame( + readr::read_delim(path, delim = "\t", quote = "", comment = "", na = "NA", + col_types = readr::cols(.default = readr::col_character()), + name_repair = "minimal", trim_ws = FALSE, progress = FALSE, + show_col_types = FALSE), + stringsAsFactors = FALSE, check.names = FALSE) + +# Headerless whitespace/TSV table (e.g. a BED of association windows, or a +# region-list) -> data.frame, character columns, `#`-prefixed lines dropped as +# comments. Matches read.table(header=FALSE, comment.char="#") for both +# whitespace- and tab-delimited inputs (runs of whitespace collapse to one +# delimiter, as read_table does). +readTableNoHeader <- function(path) + as.data.frame( + readr::read_table(path, col_names = FALSE, comment = "#", na = "NA", + col_types = readr::cols(.default = readr::col_character()), + progress = FALSE, show_col_types = FALSE), + stringsAsFactors = FALSE) + +# Write a manifest data.frame as a TSV. Matches write.table(sep="\t", +# quote=FALSE, row.names=FALSE, na="") + creates the parent dir. +writeManifest <- function(df, path) { + dir.create(dirname(path), showWarnings = FALSE, recursive = TRUE) + readr::write_tsv(df, path, na = "", quote = "none", progress = FALSE) +} + +# ---- chromosome normalization (two opposite conventions in use) ------------- +# add a "chr" prefix when missing ("22" -> "chr22"; "chr22" kept) +chromAdd <- function(x) { + x <- as.character(x) + ifelse(is.na(x) | !nzchar(x), x, + ifelse(startsWith(x, "chr"), x, paste0("chr", x))) +} +# strip a leading "chr" ("chr22" -> "22") +chromStrip <- function(x) sub("^chr", "", as.character(x), ignore.case = TRUE) + +# ---- comma-list helpers ----------------------------------------------------- +splitC <- function(x) { v <- trimws(strsplit(as.character(x), ",")[[1L]]); v[nzchar(v)] } +joinC <- function(v) paste(v, collapse = ",") +makeUnique <- function(x) joinC(unique(splitC(x))) + +# ---- path helpers ----------------------------------------------------------- +# Prefix each comma-separated file with `pre` (skip when pre is empty). +prefixPaths <- function(x, pre) + joinC(vapply(splitC(x), + function(f) if (nzchar(pre)) file.path(pre, f) else f, character(1))) + +# Resolve a possibly-stale path against the meta file that referenced it: +# exists as given -> basename in cwd -> basename in meta dir -> meta_dir/path. +adaptFilePath <- function(filePath, referenceFile) { + filePath <- trimws(filePath) + refDir <- dirname(referenceFile) + isFile <- function(f) file.exists(f) && !dir.exists(f) + if (isFile(filePath)) return(filePath) + fileName <- basename(filePath) + if (isFile(fileName)) return(fileName) + inRef <- file.path(refDir, fileName) + if (isFile(inRef)) return(inRef) + prefixed <- file.path(refDir, filePath) + if (isFile(prefixed)) return(prefixed) + stop("No valid path found for file: ", filePath) +} diff --git a/code/script/pecotmr_integration/mash.R b/code/script/pecotmr_integration/mash.R deleted file mode 100644 index 975466ccd..000000000 --- a/code/script/pecotmr_integration/mash.R +++ /dev/null @@ -1,241 +0,0 @@ -#!/usr/bin/env Rscript -# mash.R -# -# Estimate the MASH mixture-component covariance + weights via -# pecotmr::mashPipeline(). Consumes the per-region RDSes produced by -# mash_sumstats_construct.R (one per LD-block region), partitions into -# strong / random / null subsets via pecotmr::mashRandNullSample, wraps -# each partition as a per-context QtlSumStats collection (with a -# pass-through QC record), and calls mashPipeline. -# -# Inputs: -# --mash-inputs f1.rds [f2.rds ...] Per-region RDSes (each is -# list(region_id = list(z, region))). -# --study Study label for the synthesised -# QtlSumStats. Default "study". -# --ld-sketch GenotypeHandle RDS to embed in -# the synthesised QtlSumStats -# (required by mashPipeline). -# --n-random / --n-null Random / null subset sizes -# passed to mashRandNullSample. -# Defaults 4000 / 4000. -# --exclude-condition c1,c2,... Conditions to drop from the -# per-context QtlSumStats before -# running MASH. Default none. -# --alpha alpha argument to mashPipeline(). -# Default 0 (standard scale). -# --seed RNG seed. Default 999. -# --vhat-rds Optional pre-computed residual -# correlation matrix (vhat). When -# supplied, replaces -# estimate_null_correlation_simple() -# inside mashPipeline; the wrapper -# readRDS()s the file and passes -# the matrix as an in-memory R -# object (no I/O inside pecotmr). -# --prior-rds Optional pre-computed prior -# covariance matrices. The RDS is -# expected to contain either a -# named list of square matrices -# directly, OR a list with a `$U` -# slot holding that list (the -# legacy `protocol_example.EE.prior.rds` -# shape). The wrapper extracts and -# forwards the U list to -# mashPipeline's `priorCovariances` -# argument. -# --output MASH result RDS (U + w + meta). - -suppressPackageStartupMessages({ - library(argparser) - library(pecotmr) - library(GenomicRanges) - library(IRanges) - library(S4Vectors) -}) - -parser <- arg_parser("Run pecotmr::mashPipeline on per-region MASH inputs") -parser <- add_argument(parser, "--mash-inputs", - help = "Per-region MASH input RDSes", - type = "character", nargs = Inf) -parser <- add_argument(parser, "--study", - help = "Study label for the synthesised QtlSumStats", - type = "character", default = "study") -parser <- add_argument(parser, "--ld-sketch", - help = "GenotypeHandle RDS (required by mashPipeline's QC gate)", - type = "character", default = "") -parser <- add_argument(parser, "--n-random", - help = "Random subset size for mashRandNullSample", - type = "integer", default = 4000L) -parser <- add_argument(parser, "--n-null", - help = "Null subset size for mashRandNullSample", - type = "integer", default = 4000L) -parser <- add_argument(parser, "--exclude-condition", - help = "Comma-separated conditions to drop", - type = "character", default = "") -parser <- add_argument(parser, "--alpha", - help = "alpha argument to mashPipeline()", - type = "numeric", default = 0) -parser <- add_argument(parser, "--seed", - help = "RNG seed", type = "integer", default = 999L) -parser <- add_argument(parser, "--vhat-rds", - help = "Optional pre-computed residual correlation matrix RDS", - type = "character", default = "") -parser <- add_argument(parser, "--prior-rds", - help = "Optional pre-computed prior-covariance RDS (matrix list or list with $U)", - type = "character", default = "") -parser <- add_argument(parser, "--output", - help = "Output MASH-result RDS path", - type = "character") -argv <- parse_args(parser) - -# Load the optional pre-computed mash artefacts at the I/O boundary so -# the pecotmr-side call stays purely in-memory. -vhat_obj <- NULL -if (nzchar(argv$vhat_rds)) { - if (!file.exists(argv$vhat_rds)) - stop("--vhat-rds file not found: ", argv$vhat_rds) - vhat_obj <- readRDS(argv$vhat_rds) - if (!is.matrix(vhat_obj) || !is.numeric(vhat_obj)) - stop("--vhat-rds must deserialise to a numeric matrix (got '", - class(vhat_obj)[[1L]], "').") - if (nrow(vhat_obj) != ncol(vhat_obj)) - stop("--vhat-rds matrix must be square; got ", - nrow(vhat_obj), " x ", ncol(vhat_obj), ".") -} -prior_U <- NULL -if (nzchar(argv$prior_rds)) { - if (!file.exists(argv$prior_rds)) - stop("--prior-rds file not found: ", argv$prior_rds) - raw <- readRDS(argv$prior_rds) - # Accept either a named list of matrices OR a list with $U. - prior_U <- if (is.list(raw) && !is.null(raw$U)) raw$U else raw - if (!is.list(prior_U) || length(prior_U) == 0L || - is.null(names(prior_U)) || any(names(prior_U) == "")) - stop("--prior-rds must hold (or have a $U slot containing) a non-empty ", - "named list of square matrices.") -} - -inputs <- as.character(argv$mash_inputs) -if (length(inputs) == 0L) - stop("--mash-inputs requires at least one per-region RDS.") -if (!nzchar(argv$ld_sketch) || !file.exists(argv$ld_sketch)) - stop("--ld-sketch is required and must point at a GenotypeHandle RDS ", - "(mashPipeline gates on QC'd sumstats, which carry the ldSketch).") -ld_handle <- readRDS(argv$ld_sketch) -if (!methods::is(ld_handle, "GenotypeHandle")) - stop("--ld-sketch must deserialise to a GenotypeHandle (got '", - class(ld_handle)[[1L]], "').") - -exclude <- if (nzchar(argv$exclude_condition)) { - trimws(strsplit(argv$exclude_condition, ",", fixed = TRUE)[[1L]]) -} else character(0) - -# Load and concatenate per-region inputs. Each entry is -# list(region_id = list(z = matrix, region = chr:start-end)) -dat <- list() -for (path in inputs) { - x <- readRDS(path) - if (!is.list(x) || length(x) == 0L) - stop(path, " is not a non-empty list (expected per-region MASH input).") - for (rid in names(x)) { - if (rid %in% names(dat)) - stop("Duplicate region_id '", rid, "' across --mash-inputs (", - path, "); regions must be unique.") - dat[[rid]] <- x[[rid]] - } -} - -# Build a single concatenated `dat` for mashRandNullSample. We require -# every region to share the same condition set (so column-binding the -# z-matrices stays meaningful for MASH). -conditions <- colnames(dat[[1L]]$z) -for (rid in names(dat)) { - if (!identical(colnames(dat[[rid]]$z), conditions)) - stop("Region '", rid, - "' has a different condition set than the first region '", - names(dat)[[1L]], - "'; mashRandNullSample requires a common set of conditions.") -} -zStack <- do.call(rbind, lapply(dat, function(x) x$z)) -cat(sprintf("Stacked %d region(s) -> %d variants x %d conditions\n", - length(dat), nrow(zStack), ncol(zStack))) - -# Partition into strong / random / null. Strong is the input itself -# (max(|z|) >= threshold variants are downstream-filtered by mash); -# random / null are the subsets mashRandNullSample emits. -partition <- mashRandNullSample( - list(z = zStack), - nRandom = argv$n_random, - nNull = argv$n_null, - excludeCondition = exclude, - seed = argv$seed) -randomZ <- partition$random$z -nullZ <- partition$null$z -if (is.null(randomZ) || nrow(randomZ) == 0L) - stop("mashRandNullSample returned an empty random subset; ", - "increase --n-random or check the input z-matrix.") -strongZ <- zStack -# Drop excluded conditions if mashRandNullSample applied them. -if (length(exclude) > 0L) { - keepCols <- setdiff(colnames(strongZ), exclude) - strongZ <- strongZ[, keepCols, drop = FALSE] -} - -# Wrap each partition as a QtlSumStats collection: one row per -# (study, context, trait) with a single GRanges entry of the partition's -# variants. Use synthetic positions when variant IDs don't parse as -# "chr:pos:..." (mashPipeline only reads Z out of mcols). -.toQss <- function(zMat, role) { - vids <- rownames(zMat) - if (is.null(vids)) vids <- paste0("var", seq_len(nrow(zMat))) - # Try chr:pos:... decode; otherwise synthesise chr1 positions. - m <- regmatches(vids, regexec("^([^:_]+)[:_]([0-9]+)", vids)) - chrom <- vapply(m, function(x) if (length(x) >= 2L) x[[2L]] else "chr1", - character(1L)) - pos <- suppressWarnings(vapply(m, - function(x) if (length(x) >= 3L) as.integer(x[[3L]]) else NA_integer_, - integer(1L))) - pos[is.na(pos)] <- seq_along(pos)[is.na(pos)] - # One per-context entry. - entries <- lapply(seq_len(ncol(zMat)), function(j) { - gr <- GRanges(seqnames = chrom, - ranges = IRanges(start = pos, width = 1L)) - mcols(gr) <- DataFrame( - SNP = vids, A1 = rep("A", length(vids)), A2 = rep("G", length(vids)), - Z = as.numeric(zMat[, j]), - N = rep(1000L, length(vids))) - gr - }) - ctxs <- colnames(zMat) - qss <- QtlSumStats( - study = rep(argv$study, ncol(zMat)), - context = ctxs, - trait = rep("mash", ncol(zMat)), - entry = entries, - genome = "GRCh38", - ldSketch = ld_handle, - qcInfo = list(role = role, - entryAudit = vector("list", ncol(zMat)))) - qss -} - -sumStatsList <- list(strong = .toQss(strongZ, "strong"), - random = .toQss(randomZ, "random")) -if (!is.null(nullZ) && nrow(nullZ) > 0L) - sumStatsList$null <- .toQss(nullZ, "null") - -cat(sprintf("Built sumStatsList: strong=%d, random=%d, null=%s\n", - nrow(strongZ), nrow(randomZ), - if (is.null(nullZ)) "(none)" else as.character(nrow(nullZ)))) - -res <- mashPipeline( - sumStatsList = sumStatsList, - alpha = argv$alpha, - residualCorrelation = vhat_obj, - priorCovariances = prior_U, - setSeed = argv$seed) - -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -saveRDS(res, argv$output, compress = "xz") -cat(sprintf("Wrote MASH result (U + w) to %s\n", argv$output)) diff --git a/code/script/pecotmr_integration/mash_covariance.R b/code/script/pecotmr_integration/mash_covariance.R new file mode 100644 index 000000000..f48eedcfb --- /dev/null +++ b/code/script/pecotmr_integration/mash_covariance.R @@ -0,0 +1,63 @@ +#!/usr/bin/env Rscript +# mash_covariance.R +# +# Build data-driven covariance component(s) via pecotmr::mashCovarianceComponents +# -- the unified backing for mixture_prior.ipynb's per-method covariance steps: +# each step fixes a single `--component`, demonstrating that estimator on the +# `strong` subset. +# +# --component canonical cov_canonical +# --component pca cov_pca +# --component flash cov_flash (default factors) +# --component flash_nonneg cov_flash(factors = "nonneg") +# +# The covariance components are residual-correlation-independent (they read only +# the standardized effect matrix), so no Vhat is required here -- it enters at the +# prior-refinement step (mash_prior.R). +# +# Inputs: +# --data MASH input RDS with strong.b / strong.s matrices. +# --component One (or a comma-separated set) of the components above. +# --effect-model "EE" (alpha=0) or "EZ" (alpha=1). +# --npc PCs for cov_pca. Default ncol(Bhat) - 1. +# --seed RNG seed (cov_flash is stochastic). Default 999. +# --output Output covariance-component RDS (a named list of matrices). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +p <- arg_parser("Build MASH data-driven covariance component(s)") +p <- add_argument(p, "--data", type = "character", + help = "MASH input RDS (strong.b / strong.s)") +p <- add_argument(p, "--component", type = "character", default = "canonical", + help = "canonical | pca | flash | flash_nonneg (comma-separated for several)") +p <- add_argument(p, "--effect-model", type = "character", default = "EE", + help = "EE (alpha=0) or EZ (alpha=1)") +p <- add_argument(p, "--npc", type = "integer", default = NA_integer_, + help = "PCs for cov_pca (default ncol(Bhat) - 1)") +p <- add_argument(p, "--seed", type = "integer", default = 999L, + help = "RNG seed (cov_flash is stochastic)") +p <- add_argument(p, "--output", type = "character", + help = "output covariance-component RDS") +argv <- parse_args(p) + +alpha <- if (toupper(argv$effect_model) == "EZ") 1 else 0 +dat <- readRDS(argv$data) + +strong <- qtlSumStatsFromBetaMatrix( + as.matrix(dat$strong.b), as.matrix(dat$strong.s), study = "mash") + +components <- trimws(strsplit(argv$component, "[ ,]+")[[1L]]) +components <- components[nzchar(components)] +nPcs <- if (is.na(argv$npc)) NULL else argv$npc + +U <- mashCovarianceComponents(list(strong = strong), alpha = alpha, + components = components, nPcs = nPcs, + setSeed = argv$seed) + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(U, argv$output) +cat(sprintf("Wrote %d covariance matrix/matrices [%s] to %s\n", + length(U), paste(components, collapse = ","), argv$output)) diff --git a/code/script/pecotmr_integration/mash_feature_score.R b/code/script/pecotmr_integration/mash_feature_score.R new file mode 100644 index 000000000..c187e23f3 --- /dev/null +++ b/code/script/pecotmr_integration/mash_feature_score.R @@ -0,0 +1,132 @@ +#!/usr/bin/env Rscript +# mash_feature_score.R +# +# Feature scores from per-region posterior-contrast results -- unified backing +# for the four feature-score steps of mash_posterior.ipynb. Each --method fixes +# one scorer (all implemented in pecotmr, meta via metafor): +# +# --method meta calculateFeatureScores (deviation-contrast RE meta -> Z) +# --method nsig nSignificantScore (fraction of sig deviation contrasts) +# --method pval_pair metaAnalysisPerCondition (pairwise-contrast RE meta -> p) +# --method finemap scoreFromCs (credible-set-based score) +# +# One or more --contrast RDS files (from mash_posterior_contrast.R) are scored +# and stacked into a long table (gene, condition, [contrast], score, scoreType). +# Optional LD pruning of the contrast variants uses pecotmr::ldPruneByCorrelation +# (correlation-based; needs a --genotype file + --region), NOT external plink. +# +# Inputs: +# --method meta | nsig | pval_pair | finemap. +# --contrast f1 [...] per-region contrast RDS files. +# --gene-ids id,... gene labels (one per --contrast; default: file basename). +# --p-cutoff X nsig significance cutoff. Default 1e-5. +# --meta-method M meta / pval_pair estimator (metafor). Default REML. +# --se-cutoff X pval_pair SE cutoff. Default 1e-3. +# --fine-mapping f finemap: table with cs_order / pip / variants columns. +# --conditions c,... finemap: conditions to score (default: all contexts). +# --genotype f optional PLINK/VCF/GDS prefix for LD pruning. +# --region chr:s-e region for --genotype extraction. +# --cor-threshold X LD-prune |correlation| threshold. Default 0.45 (~r2 0.2). +# --output output long-format score table. + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +p <- arg_parser("MASH feature scores from posterior contrasts") +p <- add_argument(p, "--method", type = "character", + help = "meta | nsig | pval_pair | finemap") +p <- add_argument(p, "--contrast", type = "character", nargs = Inf, + help = "per-region contrast RDS files") +p <- add_argument(p, "--gene-ids", type = "character", default = "", + help = "comma-separated gene labels (one per --contrast)") +p <- add_argument(p, "--p-cutoff", type = "numeric", default = 1e-5, + help = "nsig significance cutoff") +p <- add_argument(p, "--meta-method", type = "character", default = "REML", + help = "meta / pval_pair estimator (metafor)") +p <- add_argument(p, "--se-cutoff", type = "numeric", default = 1e-3, + help = "pval_pair SE cutoff") +p <- add_argument(p, "--fine-mapping", type = "character", default = "", + help = "finemap: table with cs_order/pip/variants") +p <- add_argument(p, "--conditions", type = "character", default = "", + help = "finemap: conditions to score") +p <- add_argument(p, "--genotype", type = "character", default = "", + help = "optional genotype prefix for LD pruning") +p <- add_argument(p, "--region", type = "character", default = "", + help = "region for --genotype extraction") +p <- add_argument(p, "--cor-threshold", type = "numeric", default = 0.45, + help = "LD-prune |correlation| threshold") +p <- add_argument(p, "--output", type = "character", help = "output score RDS") +argv <- parse_args(p) + +splitCsv <- function(x) if (nzchar(x)) trimws(strsplit(x, ",", fixed = TRUE)[[1L]]) else character(0) + +files <- as.character(argv$contrast) +if (length(files) == 0L) stop("--contrast requires at least one RDS file.") +geneIds <- splitCsv(argv$gene_ids) +if (length(geneIds) == 0L) geneIds <- tools::file_path_sans_ext(basename(files)) +if (length(geneIds) != length(files)) + stop("--gene-ids length must match --contrast.") + +# Optional LD pruning: keep the contrast rows whose variants survive +# ldPruneByCorrelation on their genotype dosages. No-op without --genotype. +ldPruneContrast <- function(cr) { + if (!nzchar(argv$genotype) || !nzchar(argv$region)) return(cr) + X <- loadGenotypeRegion(genotype = argv$genotype, region = argv$region) + # orient SNPs as columns; keep only the contrast variants that are present + if (is.null(colnames(X)) && !is.null(rownames(X))) X <- t(X) + common <- intersect(rownames(cr), colnames(X)) + if (length(common) < 2L) return(cr) + keep <- ldPruneByCorrelation(X[, common, drop = FALSE], + corThres = argv$cor_threshold)$X.new + cr[colnames(keep), , drop = FALSE] +} + +scoreOne <- function(file, gene) { + cr <- ldPruneContrast(as.data.frame(readRDS(file))) + if (argv$method == "meta") { + fs <- calculateFeatureScores(cr, metaMethod = argv$meta_method) + if (nrow(fs) == 0L) return(NULL) + data.frame(gene = gene, condition = fs$condition, contrast = NA_character_, + score = fs$zScore, scoreType = "meta_z", stringsAsFactors = FALSE) + } else if (argv$method == "nsig") { + ns <- nSignificantScore(cr, pCutoff = argv$p_cutoff) + if (nrow(ns) == 0L) return(NULL) + data.frame(gene = gene, condition = ns$condition, contrast = NA_character_, + score = ns$ratio, scoreType = "nsig_ratio", stringsAsFactors = FALSE) + } else if (argv$method == "pval_pair") { + eff <- as.matrix(cr[, grep("mean_contrast.*_vs_", names(cr)), drop = FALSE]) + se <- as.matrix(cr[, grep("se_contrast.*_vs_", names(cr)), drop = FALSE]) + colnames(se) <- colnames(eff) # metaAnalysisPerCondition needs matching names + mp <- metaAnalysisPerCondition(eff, se, seCutoff = argv$se_cutoff, + metaMethod = argv$meta_method) + if (nrow(mp) == 0L) return(NULL) + data.frame(gene = gene, condition = mp$condition, contrast = mp$contrast, + score = mp$meta_pvalue, scoreType = "pval_pair", stringsAsFactors = FALSE) + } else if (argv$method == "finemap") { + fm <- as.data.frame(readRDS(argv$fine_mapping)) + conds <- splitCsv(argv$conditions) + if (length(conds) == 0L) + conds <- unique(sub("_deviation$", "", + sub("^mean_contrast_", "", + grep("mean_contrast.*deviation", names(cr), value = TRUE)))) + do.call(rbind, lapply(conds, function(cond) { + data.frame(gene = gene, condition = cond, contrast = NA_character_, + score = scoreFromCs(fm, cr, cond), scoreType = "finemap", + stringsAsFactors = FALSE) + })) + } else { + stop("--method must be one of meta | nsig | pval_pair | finemap.") + } +} + +out <- do.call(rbind, Filter(Negate(is.null), + Map(scoreOne, files, geneIds))) +if (is.null(out)) out <- data.frame(gene = character(0), condition = character(0), + contrast = character(0), score = numeric(0), scoreType = character(0)) + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(out, argv$output, compress = "xz") +cat(sprintf("Wrote %s feature scores (%d rows over %d region(s)) to %s\n", + argv$method, nrow(out), length(files), argv$output)) diff --git a/code/script/pecotmr_integration/mash_feature_score_merge.R b/code/script/pecotmr_integration/mash_feature_score_merge.R new file mode 100644 index 000000000..1570f7dd8 --- /dev/null +++ b/code/script/pecotmr_integration/mash_feature_score_merge.R @@ -0,0 +1,34 @@ +#!/usr/bin/env Rscript +# mash_feature_score_merge.R +# +# Merge per-chunk feature-score tables (from mash_feature_score.R) into one +# table -- the shared `_2` merge step of the feature-score workflows in +# mash_posterior.ipynb. All chunks share the long format +# (gene, condition, [contrast], score, scoreType), so the merge is a row-bind. +# +# Inputs: +# --scores f1 [f2 ...] per-chunk feature-score RDS files. +# --output output table; ".csv" -> CSV, else RDS. + +suppressPackageStartupMessages(library(argparser)) + +p <- arg_parser("Merge per-chunk MASH feature-score tables") +p <- add_argument(p, "--scores", type = "character", nargs = Inf, + help = "per-chunk feature-score RDS files") +p <- add_argument(p, "--output", type = "character", help = "output CSV or RDS") +argv <- parse_args(p) + +files <- as.character(argv$scores) +if (length(files) == 0L) stop("--scores requires at least one RDS file.") + +merged <- do.call(rbind, lapply(files, function(f) as.data.frame(readRDS(f)))) +if (is.null(merged)) merged <- data.frame() + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +if (grepl("\\.csv$", argv$output)) { + utils::write.csv(merged, argv$output, row.names = FALSE) +} else { + saveRDS(merged, argv$output, compress = "xz") +} +cat(sprintf("Merged %d chunk(s) -> %d rows to %s\n", + length(files), nrow(merged), argv$output)) diff --git a/code/script/pecotmr_integration/mash_fit.R b/code/script/pecotmr_integration/mash_fit.R new file mode 100644 index 000000000..bd1d83226 --- /dev/null +++ b/code/script/pecotmr_integration/mash_fit.R @@ -0,0 +1,63 @@ +#!/usr/bin/env Rscript +# mash_fit.R +# +# Fit a MASH mixture model -- the `[mash_1]` step of mash_fit.ipynb. Reads the +# pre-partitioned MASH input (random.b / random.s effect-size matrices), a +# residual correlation (Vhat), and a pre-computed prior covariance list ($U), +# wraps the random subset as a beta-scale QtlSumStats (no LD reference needed -- +# mash operates across conditions per variant), and calls pecotmr::mashModelFit. +# +# The mixture weights are learned on the `random` subset (Urbut et al. 2019); +# the resulting model is consumed by mash_posterior.R on the strong / target set. +# +# Inputs: +# --data MASH input RDS: list(random.b, random.s, strong.b, strong.s) +# -- Bhat / Shat matrices (variants x conditions). +# --vhat-data Residual correlation (Vhat) RDS (conditions x conditions). +# --prior-data Prior RDS carrying a `$U` covariance list (from the +# mixture-prior step). +# --effect-model "EE" (beta scale, alpha = 0) or "EZ" (z scale, alpha = 1). +# --output-level mashr outputlevel forwarded to mash(). Default 4. +# --output Output model RDS (list(mash_model, vhat_file, prior_file)). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +p <- arg_parser("Fit a MASH mixture model via pecotmr::mashModelFit") +p <- add_argument(p, "--data", type = "character", + help = "MASH input RDS (random.b/random.s/strong.b/strong.s)") +p <- add_argument(p, "--vhat-data", type = "character", + help = "Residual correlation (Vhat) RDS") +p <- add_argument(p, "--prior-data", type = "character", + help = "Prior RDS carrying a $U covariance list") +p <- add_argument(p, "--effect-model", type = "character", default = "EE", + help = "EE (beta, alpha=0) or EZ (z, alpha=1)") +p <- add_argument(p, "--output-level", type = "integer", default = 4L, + help = "mashr outputlevel") +p <- add_argument(p, "--output", type = "character", help = "Output model RDS") +argv <- parse_args(p) + +alpha <- if (toupper(argv$effect_model) == "EZ") 1 else 0 + +dat <- readRDS(argv$data) +vhat <- readRDS(argv$vhat_data) +prior <- readRDS(argv$prior_data) +U <- if (is.list(prior) && !is.null(prior$U)) prior$U else prior + +# Wrap the random (fit) subset as a beta-scale QtlSumStats. ldSketch stays NULL: +# mash needs no LD reference. +random <- qtlSumStatsFromBetaMatrix( + as.matrix(dat$random.b), as.matrix(dat$random.s), study = "mash") + +model <- mashModelFit(list(random = random), alpha = alpha, + priorCovariances = U, vhat = vhat, + fitOn = "random", outputLevel = argv$output_level) + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(list(mash_model = model, + vhat_file = argv$vhat_data, + prior_file = argv$prior_data), argv$output) +cat(sprintf("Wrote MASH model (%d prior components) to %s\n", + length(U), argv$output)) diff --git a/code/script/pecotmr_integration/mash_plot_prior.R b/code/script/pecotmr_integration/mash_plot_prior.R new file mode 100644 index 000000000..c5be33c73 --- /dev/null +++ b/code/script/pecotmr_integration/mash_plot_prior.R @@ -0,0 +1,105 @@ +#!/usr/bin/env Rscript +# mash_plot_prior.R +# +# Plot the MASH prior covariance matrices as sharing heatmaps -- the wrapper +# backing mixture_prior.ipynb's `plot_U` step. Reads a prior RDS (a +# list(U, w[, loglik]) as written by mash_prior.R) and renders one heatmap per +# weighted covariance component into a multi-panel PDF. +# +# Inputs: +# --data Prior RDS (list with $U covariance list + $w weights). +# --name Optional sub-element of the RDS to plot (dat[[name]]). +# --max-comp Max components to show (-1 = all above --tol). Default -1. +# --to-cor Convert covariances to correlations before plotting. +# --tol Weight threshold for "shown" components. Default 1E-6. +# --remove-label Replace condition names with t1..tn. +# --output Output PDF path. + +suppressPackageStartupMessages({ + library(argparser) + library(reshape2) + library(ggplot2) +}) + +p <- arg_parser("Plot MASH prior covariance matrices as sharing heatmaps") +p <- add_argument(p, "--data", type = "character", help = "prior RDS (list(U, w))") +p <- add_argument(p, "--name", type = "character", default = "", + help = "optional sub-element of the RDS to plot") +p <- add_argument(p, "--max-comp", type = "integer", default = -1L, + help = "max components to show (-1 = all above --tol)") +p <- add_argument(p, "--to-cor", flag = TRUE, + help = "convert covariances to correlations") +p <- add_argument(p, "--tol", type = "numeric", default = 1e-6, + help = "weight threshold for shown components") +p <- add_argument(p, "--remove-label", flag = TRUE, + help = "replace condition names with t1..tn") +p <- add_argument(p, "--output", type = "character", help = "output PDF path") +argv <- parse_args(p) + +plot_sharing <- function(X, col = "black", to_cor = FALSE, title = "", + remove_names = FALSE) { + clrs <- colorRampPalette(rev(c("#D73027", "#FC8D59", "#FEE090", "#FFFFBF", + "#E0F3F8", "#91BFDB", "#4575B4")))(128) + lat <- if (to_cor) cov2cor(X) else X / max(diag(X)) + lat[lower.tri(lat)] <- NA + n <- nrow(lat) + if (remove_names) { + colnames(lat) <- rownames(lat) <- paste0("t", seq_len(n)) + } + melted <- melt(lat[n:1, ], na.rm = TRUE) + pl <- ggplot(data = melted, aes(Var2, Var1, fill = value)) + + geom_tile(color = "white") + ggtitle(title) + + scale_fill_gradientn(colors = clrs, limit = c(-1, 1), space = "Lab") + + theme_minimal() + coord_fixed() + + theme(axis.title.x = element_blank(), axis.title.y = element_blank(), + axis.text.x = element_text(color = col, size = 8, angle = 45, hjust = 1), + axis.text.y = element_text(color = rev(col), size = 8), + title = element_text(size = 10), panel.border = element_blank(), + panel.background = element_blank(), axis.ticks = element_blank(), + legend.justification = c(1, 0), legend.position = c(0.6, 0), + legend.direction = "horizontal") + + guides(fill = guide_colorbar(title = "", barwidth = 7, barheight = 1, + title.position = "top", title.hjust = 0.5)) + if (remove_names) { + pl <- pl + scale_x_discrete(labels = seq_len(n)) + + scale_y_discrete(labels = rev(seq_len(n))) + } + pl +} + +dat <- readRDS(argv$data) +if (nzchar(argv$name)) { + if (is.null(dat[[argv$name]])) stop("Cannot find '", argv$name, "' in ", argv$data) + dat <- dat[[argv$name]] +} +if (is.null(names(dat$U))) names(dat$U) <- paste0("Comp_", seq_along(dat$U)) + +# Align weights to the covariance components by name: get_estimated_pi() returns +# one extra entry for the null component, so `$w` is one longer than `$U`. +w <- if (!is.null(names(dat$w))) dat$w[names(dat$U)] else dat$w[seq_along(dat$U)] +w[is.na(w)] <- 0 +meta <- data.frame(U = names(dat$U), w = as.numeric(w), stringsAsFactors = FALSE) +n_comp <- length(meta$U[which(meta$w > argv$tol)]) +meta <- head(meta[order(meta$w, decreasing = TRUE), ], + if (argv$max_comp > 1L) argv$max_comp else nrow(meta)) +message(sprintf("%d of %d components have weight > %g", n_comp, length(dat$w), argv$tol)) + +res <- list() +for (i in seq_len(n_comp)) { + title <- paste(meta$U[i], "w =", round(meta$w[i], 6)) + m <- dat$U[[meta$U[i]]] + m <- if (is.list(m)) m$mat else m # updated udr structure carries $mat + if (is.matrix(m)) { + res[[length(res) + 1L]] <- plot_sharing(m, to_cor = argv$to_cor, title = title, + remove_names = argv$remove_label) + } +} + +unit <- 4; n_col <- 5; n_row <- ceiling(length(res) / n_col) +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +pdf(argv$output, width = unit * n_col, height = unit * n_row) +do.call(gridExtra::grid.arrange, + c(res, list(ncol = n_col, nrow = n_row, + bottom = sprintf("Data source: %s", basename(argv$data))))) +dev.off() +cat(sprintf("Wrote %d covariance heatmap(s) to %s\n", length(res), argv$output)) diff --git a/code/script/pecotmr_integration/mash_posterior.R b/code/script/pecotmr_integration/mash_posterior.R new file mode 100644 index 000000000..50230e102 --- /dev/null +++ b/code/script/pecotmr_integration/mash_posterior.R @@ -0,0 +1,78 @@ +#!/usr/bin/env Rscript +# mash_posterior.R +# +# Compute MASH posterior matrices for a target set given a fitted model -- +# the `[mash_2]` step of mash_fit.ipynb (posterior on the strong subset) and the +# per-analysis-unit `posterior_1` step of mash_posterior.ipynb. Wraps the target +# Bhat / Shat as a beta-scale QtlSumStats (no LD reference needed) and calls +# pecotmr::mashPosterior. +# +# Inputs: +# --data RDS carrying the target Bhat / Shat matrices. +# --bhat-key List element for the target Bhat. Default "strong.b". +# --shat-key List element for the target Shat. Default "strong.s". +# --vhat-data Residual correlation (Vhat) RDS. +# --mash-model Model RDS from mash_fit.R (uses its $mash_model element). +# --effect-model "EE" (alpha=0) or "EZ" (alpha=1). +# --exclude-condition Comma/space-separated condition names OR 1-based column +# indices to drop before computing posteriors. Default none. +# --no-posterior-cov Omit the full posterior covariance array. +# --output Output posterior RDS. + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +p <- arg_parser("Compute MASH posterior matrices via pecotmr::mashPosterior") +p <- add_argument(p, "--data", type = "character", + help = "RDS with the target Bhat/Shat matrices") +p <- add_argument(p, "--bhat-key", type = "character", default = "strong.b", + help = "list element for the target Bhat") +p <- add_argument(p, "--shat-key", type = "character", default = "strong.s", + help = "list element for the target Shat") +p <- add_argument(p, "--vhat-data", type = "character", + help = "Residual correlation (Vhat) RDS") +p <- add_argument(p, "--mash-model", type = "character", + help = "Model RDS from mash_fit.R (uses $mash_model)") +p <- add_argument(p, "--effect-model", type = "character", default = "EE", + help = "EE (alpha=0) or EZ (alpha=1)") +p <- add_argument(p, "--exclude-condition", type = "character", default = "", + help = "condition names or 1-based indices to drop") +p <- add_argument(p, "--no-posterior-cov", flag = TRUE, + help = "omit the full posterior covariance array") +p <- add_argument(p, "--output", type = "character", help = "Output posterior RDS") +argv <- parse_args(p) + +alpha <- if (toupper(argv$effect_model) == "EZ") 1 else 0 + +dat <- readRDS(argv$data) +vhat <- readRDS(argv$vhat_data) +mm <- readRDS(argv$mash_model) +model <- if (is.list(mm) && !is.null(mm$mash_model)) mm$mash_model else mm + +bhat <- as.matrix(dat[[argv$bhat_key]]) +shat <- as.matrix(dat[[argv$shat_key]]) +target <- qtlSumStatsFromBetaMatrix(bhat, shat, study = "mash") +conds <- colnames(bhat) + +# Resolve --exclude-condition tokens: numeric tokens are 1-based column indices +# (the legacy mash_posterior CLI form), everything else is a condition name. +exTok <- trimws(strsplit(argv$exclude_condition, "[ ,]+")[[1L]]) +exTok <- exTok[nzchar(exTok)] +exclude <- character(0) +if (length(exTok) > 0L) { + idxLike <- grepl("^[0-9]+$", exTok) + byIdx <- suppressWarnings(as.integer(exTok[idxLike])) + byIdx <- byIdx[byIdx >= 1L & byIdx <= length(conds)] + exclude <- unique(c(conds[byIdx], exTok[!idxLike])) +} + +post <- mashPosterior(model, target, alpha = alpha, vhat = vhat, + excludeCondition = exclude, + outputPosteriorCov = !argv$no_posterior_cov) + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(post, argv$output) +cat(sprintf("Wrote MASH posterior (%d variants x %d conditions) to %s\n", + nrow(post$PosteriorMean), ncol(post$PosteriorMean), argv$output)) diff --git a/code/script/pecotmr_integration/mash_posterior_contrast.R b/code/script/pecotmr_integration/mash_posterior_contrast.R new file mode 100644 index 000000000..0653903e5 --- /dev/null +++ b/code/script/pecotmr_integration/mash_posterior_contrast.R @@ -0,0 +1,76 @@ +#!/usr/bin/env Rscript +# mash_posterior_contrast.R +# +# Per-region posterior contrasts -- the `mash_posterior_contrast_1` step of +# mash_posterior.ipynb. Reads a mash posterior (PosteriorMean + PosteriorCov, +# from mash_posterior.R) and the original effect matrix, builds the condition +# grouping vector, and calls pecotmr::mashPosteriorContrast (which maps +# fitMashContrast over every variant: deviation + pairwise contrasts). +# +# Inputs: +# --posterior Posterior RDS carrying PosteriorMean + PosteriorCov. +# --orig-data RDS with the original effect matrix used for the +# posterior (same variant rows / order as the posterior). +# --orig-key List element holding the effect matrix. Default "bhat" +# (set to "" if the RDS is a bare matrix). +# --cells c1,c2,... Condition order used to seed the grouping vector. +# Default: the posterior's columns. +# --group1/2/3 c,... Comma-separated condition groups -- replicate +# populations of one cell type share contrast weight. +# --grouping-recipe f File of comma-separated groups (one group per line); +# overrides --group1/2/3. +# --output Output contrast RDS (variants x contrasts). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +p <- arg_parser("Per-region mash posterior contrasts via mashPosteriorContrast") +p <- add_argument(p, "--posterior", type = "character", + help = "posterior RDS (PosteriorMean + PosteriorCov)") +p <- add_argument(p, "--orig-data", type = "character", + help = "RDS with the original effect matrix") +p <- add_argument(p, "--orig-key", type = "character", default = "bhat", + help = "list element for the effect matrix ('' = bare matrix)") +p <- add_argument(p, "--cells", type = "character", default = "", + help = "comma-separated condition order for grouping") +p <- add_argument(p, "--group1", type = "character", default = "", + help = "comma-separated condition group 1") +p <- add_argument(p, "--group2", type = "character", default = "", + help = "comma-separated condition group 2") +p <- add_argument(p, "--group3", type = "character", default = "", + help = "comma-separated condition group 3") +p <- add_argument(p, "--grouping-recipe", type = "character", default = "", + help = "file of comma-separated groups, one per line") +p <- add_argument(p, "--output", type = "character", help = "output contrast RDS") +argv <- parse_args(p) + +splitCsv <- function(x) if (nzchar(x)) trimws(strsplit(x, ",", fixed = TRUE)[[1L]]) else character(0) + +post <- readRDS(argv$posterior) +pm <- as.matrix(post$PosteriorMean) +pv <- post$PosteriorCov +orig <- readRDS(argv$orig_data) +if (nzchar(argv$orig_key)) orig <- orig[[argv$orig_key]] +orig <- as.matrix(orig) + +# Grouping vector: 0 = independent condition; positive ints tie replicate +# populations of one cell type together (see mashPosteriorContrast/fitMashContrast). +cells <- splitCsv(argv$cells) +if (length(cells) == 0L) cells <- colnames(pm) +grouping <- setNames(rep(0L, length(cells)), cells) +groups <- if (nzchar(argv$grouping_recipe)) { + lapply(readLines(argv$grouping_recipe), function(g) trimws(strsplit(g, ",")[[1L]])) +} else { + Filter(length, list(splitCsv(argv$group1), splitCsv(argv$group2), splitCsv(argv$group3))) +} +for (i in seq_along(groups)) grouping[intersect(groups[[i]], names(grouping))] <- i + +cr <- mashPosteriorContrast(pm, pv, orig, + grouping = if (any(grouping > 0L)) grouping else NULL) + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(cr, argv$output, compress = "xz") +cat(sprintf("Wrote posterior contrasts (%d variants x %d contrasts) to %s\n", + nrow(cr), ncol(cr), argv$output)) diff --git a/code/script/pecotmr_integration/mash_posterior_contrast_plot.R b/code/script/pecotmr_integration/mash_posterior_contrast_plot.R new file mode 100644 index 000000000..0f983d381 --- /dev/null +++ b/code/script/pecotmr_integration/mash_posterior_contrast_plot.R @@ -0,0 +1,73 @@ +#!/usr/bin/env Rscript +# mash_posterior_contrast_plot.R +# +# Render the posterior-contrast significance summary as a symmetric heatmap -- +# the `mash_posterior_contrast_3` / `posterior_cntrast_plot` step of +# mash_posterior.ipynb. Lower triangle = significant SNP-feature-pair ratio, +# upper triangle = significant-feature ratio, per pairwise condition contrast. +# +# Inputs: +# --data summary CSV from mash_posterior_contrast_summary.R +# (rows n_sig_snp/n_snp/n_sig_feature/n_all_feature). +# --output output heatmap PNG. + +suppressPackageStartupMessages({ + library(argparser) + library(dplyr) + library(tidyverse) + library(ggnewscale) +}) + +p <- arg_parser("Plot the posterior-contrast significance summary heatmap") +p <- add_argument(p, "--data", type = "character", help = "summary CSV") +p <- add_argument(p, "--output", type = "character", help = "output PNG") +argv <- parse_args(p) + +df <- read.csv(argv$data, row.names = 1, check.names = FALSE) + +# Normalize each pairwise column name so con1 <= con2 alphabetically. +for (i in seq_len(ncol(df))) { + parts <- strsplit(colnames(df)[i], "_vs_", fixed = TRUE)[[1L]] + if (length(parts) == 2L && parts[1] > parts[2]) + colnames(df)[i] <- paste0(parts[2], "_vs_", parts[1]) +} + +# Two ratios: SNP-feature-pair (n_sig_snp / n_snp) and feature (n_sig / n_all). +snpRatio <- as.data.frame(t(df["n_sig_snp", ] / df["n_snp", ])) +colnames(snpRatio) <- "ratio"; snpRatio$group <- "snp" +fetRatio <- as.data.frame(t(df["n_sig_feature", ] / df["n_all_feature", ])) +rownames(fetRatio) <- vapply(strsplit(rownames(fetRatio), "_vs_", fixed = TRUE), + function(x) paste0(x[2], "_vs_", x[1]), character(1)) +colnames(fetRatio) <- "ratio"; fetRatio$group <- "feature" +ratio <- rbind(snpRatio, fetRatio) + +# Make the grid symmetric by adding the con_vs_con diagonal at 0. +cons <- unique(vapply(strsplit(rownames(ratio), "_vs_", fixed = TRUE), + `[`, character(1), 1L)) +for (con in cons) ratio[paste0(con, "_vs_", con), ] <- list(0, 0) + +ratio$con1 <- vapply(strsplit(rownames(ratio), "_vs_", fixed = TRUE), `[`, character(1), 1L) +ratio$con2 <- vapply(strsplit(rownames(ratio), "_vs_", fixed = TRUE), `[`, character(1), 2L) +ratio$score1 <- ratio$score2 <- 0 +ratio$score1[ratio$group == "snp"] <- ratio$ratio[ratio$group == "snp"] +ratio$score2[ratio$group == "feature"] <- ratio$ratio[ratio$group == "feature"] +ratio$label <- paste0(round(ratio$ratio, 4) * 100, "%") +ratio$label[ratio$group == 0] <- NA + +numCols <- length(cons) +side <- 4 + numCols * 0.5 + +pl <- ggplot(ratio[ratio$group == "snp", ], aes(x = con1, y = con2)) + + geom_tile(aes(fill = score1)) + + scale_fill_gradient2("SNP_Feature pair", low = "#762A83", mid = "white", + high = "#1B7837") + + new_scale("fill") + + geom_tile(aes(fill = score2), data = subset(ratio, group != "snp")) + + scale_fill_gradient2("Feature", low = "#1B7837", mid = "white", + high = "#762A83") + + geom_text(data = ratio, aes(label = label)) + + theme_bw() + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +ggsave(argv$output, plot = pl, width = side, height = side) +cat(sprintf("Wrote contrast heatmap (%d conditions) to %s\n", numCols, argv$output)) diff --git a/code/script/pecotmr_integration/mash_posterior_contrast_summary.R b/code/script/pecotmr_integration/mash_posterior_contrast_summary.R new file mode 100644 index 000000000..c6753e182 --- /dev/null +++ b/code/script/pecotmr_integration/mash_posterior_contrast_summary.R @@ -0,0 +1,63 @@ +#!/usr/bin/env Rscript +# mash_posterior_contrast_summary.R +# +# Summarize posterior-contrast significance across regions -- the +# `mash_posterior_contrast_2` step of mash_posterior.ipynb. For each pairwise +# condition contrast, counts significant SNP-level contrasts (p < --p-cutoff) +# and the number of features (regions) with any significant SNP, over all the +# per-region contrast RDS files. Writes a 4 x n_pairs CSV that +# mash_posterior_contrast_plot.R renders. +# +# Inputs: +# --contrast f1 [...] per-region contrast RDS files (from mash_posterior_contrast.R). +# --cells c1,c2,... conditions (columns) whose pairwise contrasts to tally. +# --p-cutoff X significance cutoff. Default 1e-5. +# --output output summary CSV (rows: n_sig_snp / n_snp / +# n_sig_feature / n_all_feature; cols: pairwise contrasts). + +suppressPackageStartupMessages({ + library(argparser) +}) + +p <- arg_parser("Summarize posterior-contrast significance across regions") +p <- add_argument(p, "--contrast", type = "character", nargs = Inf, + help = "per-region contrast RDS files") +p <- add_argument(p, "--cells", type = "character", + help = "comma-separated conditions") +p <- add_argument(p, "--p-cutoff", type = "numeric", default = 1e-5, + help = "significance cutoff") +p <- add_argument(p, "--output", type = "character", help = "output summary CSV") +argv <- parse_args(p) + +cells <- trimws(strsplit(argv$cells, ",", fixed = TRUE)[[1L]]) +files <- as.character(argv$contrast) +if (length(files) == 0L) stop("--contrast requires at least one RDS file.") + +pairs <- apply(utils::combn(cells, 2L), 2L, paste, collapse = "_vs_") +summary <- matrix(0, nrow = 4L, ncol = length(pairs), + dimnames = list(c("n_sig_snp", "n_snp", + "n_sig_feature", "n_all_feature"), pairs)) + +crs <- lapply(files, function(f) as.data.frame(readRDS(f))) + +for (pair in pairs) { + for (cr in crs) { + pcol <- grep(paste0("p_contrast_", pair), names(cr), value = TRUE, fixed = FALSE) + # exact pairwise column (avoid deviation / substring collisions) + pcol <- pcol[pcol == paste0("p_contrast_", pair)] + if (length(pcol) == 0L) next + pv <- as.numeric(cr[[pcol[1L]]]) + pv <- pv[!is.na(pv)] + if (length(pv) == 0L) next + nSig <- sum(pv < argv$p_cutoff) + summary["n_sig_snp", pair] <- summary["n_sig_snp", pair] + nSig + summary["n_snp", pair] <- summary["n_snp", pair] + length(pv) + summary["n_sig_feature", pair] <- summary["n_sig_feature", pair] + (nSig > 0) + summary["n_all_feature", pair] <- summary["n_all_feature", pair] + 1L + } +} + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +utils::write.csv(as.data.frame(summary), argv$output) +cat(sprintf("Wrote contrast summary (%d pairwise contrasts over %d region(s)) to %s\n", + length(pairs), length(files), argv$output)) diff --git a/code/script/pecotmr_integration/mash_preprocessing.R b/code/script/pecotmr_integration/mash_preprocessing.R new file mode 100644 index 000000000..49570458c --- /dev/null +++ b/code/script/pecotmr_integration/mash_preprocessing.R @@ -0,0 +1,125 @@ +#!/usr/bin/env Rscript +# mash_preprocessing.R +# +# Assemble the MASH mixture-model input (`mash_input.rds`) from per-region S4 +# objects via pecotmr::mashInput -- the merge step of mash_preprocessing.ipynb. +# +# Each --objects RDS is ONE region, holding either: +# * a QtlSumStats -- multi-context summary statistics (e.g. from +# mash_sumstats_construct.R over tensorqtl files); +# strong = the most significant variant (max|z|) +# per context. +# * a FineMappingResult -- multi-context fine-mapping (e.g. from +# fine_mapping.R); strong = the lead variant +# (max PIP) of each credible set per condition. +# Random / null background rows are sampled from every object identically. +# mashInput() merges the per-region partitions and appends the strong XtX +# cross-product; the output is the flat list(strong.b/strong.s/strong.z, +# random.*, null.*, XtX) consumed by mixture_prior / mash_fit. +# +# Inputs: +# --objects f1 [f2 ...] Per-region RDS files (QtlSumStats or +# FineMappingResult). Mixed classes are allowed. +# --region-ids id1,... Optional comma-separated region labels (one per +# object; default = file basenames). +# --n-random N Random rows sampled per object. Default 10. +# --n-null N Null (max|z|<2) rows sampled per object. Default 10. +# --exclude-condition c Comma-separated condition names to drop. Default none. +# --coverage X Credible-set coverage for FineMappingResult strong +# selection. Default 0.95. +# --z-only Emit only the .z matrices (drop .b/.s). +# --sig-p-cutoff X Strong-partition significance cutoff. Default 1e-6. +# --independent-variant-list Optional LD-pruned independent-SNP list +# (a variant_id column or CHROM/POS; gzip OK). +# Restricts the random/null background to matching +# variants -- allele-aware via matchVariants (strong +# is never filtered). +# --seed N RNG seed for random/null sampling. Default 999. +# --output Output mash_input.rds path. + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +p <- arg_parser("Assemble MASH input from per-region S4 objects via mashInput") +p <- add_argument(p, "--objects", type = "character", nargs = Inf, + help = "Per-region RDS files (QtlSumStats or FineMappingResult)") +p <- add_argument(p, "--region-ids", type = "character", default = "", + help = "Comma-separated region labels (default: file basenames)") +p <- add_argument(p, "--n-random", type = "integer", default = 10L, + help = "Random rows sampled per object") +p <- add_argument(p, "--n-null", type = "integer", default = 10L, + help = "Null rows sampled per object") +p <- add_argument(p, "--exclude-condition", type = "character", default = "", + help = "Comma-separated conditions to drop") +p <- add_argument(p, "--coverage", type = "numeric", default = 0.95, + help = "CS coverage for FineMappingResult strong selection") +p <- add_argument(p, "--z-only", flag = TRUE, help = "Emit only .z matrices") +p <- add_argument(p, "--sig-p-cutoff", type = "numeric", default = 1e-6, + help = "Strong-partition significance cutoff") +p <- add_argument(p, "--independent-variant-list", type = "character", default = "", + help = "Optional LD-pruned independent-SNP list; restricts the random/null background") +p <- add_argument(p, "--seed", type = "integer", default = 999L, help = "RNG seed") +p <- add_argument(p, "--output", type = "character", help = "Output mash_input.rds") +argv <- parse_args(p) + +# Read a variant-id list from --independent-variant-list. Handles a header'd +# table with a variant_id (or CHROM/POS) column and gzipped input; matchVariants +# inside mashInput does the actual allele-aware matching. +readIndependentVariantIds <- function(path) { + df <- suppressWarnings(as.data.frame(vroom::vroom( + path, comment = "", show_col_types = FALSE, progress = FALSE))) + if (ncol(df) == 0L || nrow(df) == 0L) + stop("--independent-variant-list is empty or unreadable: ", path) + nm <- tolower(sub("^#", "", names(df))) + idCol <- which(nm %in% c("variant_id", "id", "snp", "rsid"))[1L] + if (!is.na(idCol)) return(as.character(df[[idCol]])) + cCol <- which(nm %in% c("chrom", "chr", "chromosome"))[1L] + pCol <- which(nm %in% c("pos", "position", "bp"))[1L] + if (!is.na(cCol) && !is.na(pCol)) + return(paste0(df[[cCol]], ":", df[[pCol]])) + as.character(df[[1L]]) +} + +paths <- as.character(argv$objects) +if (length(paths) == 0L) stop("--objects requires at least one RDS file.") +missing <- paths[!file.exists(paths)] +if (length(missing) > 0L) + stop("--objects file(s) not found: ", paste(missing, collapse = ", ")) + +splitCsv <- function(x) if (nzchar(x)) trimws(strsplit(x, ",", fixed = TRUE)[[1L]]) else character(0) + +regionIds <- splitCsv(argv$region_ids) +if (length(regionIds) == 0L) { + regionIds <- tools::file_path_sans_ext(basename(paths)) +} +if (length(regionIds) != length(paths)) + stop("--region-ids length (", length(regionIds), ") must match --objects (", + length(paths), ").") + +objects <- setNames(lapply(paths, readRDS), regionIds) + +independentVariants <- if (nzchar(argv$independent_variant_list)) + readIndependentVariantIds(argv$independent_variant_list) else NULL + +result <- mashInput( + objects, + nRandom = argv$n_random, + nNull = argv$n_null, + excludeCondition = splitCsv(argv$exclude_condition), + coverage = argv$coverage, + zOnly = argv$z_only, + sigPCutoff = argv$sig_p_cutoff, + independentVariants = independentVariants, + seed = argv$seed) + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(result, argv$output, compress = "xz") + +strongN <- if (is.null(result$strong.z)) 0L else nrow(as.matrix(result$strong.z)) +randomN <- if (is.null(result$random.z)) 0L else nrow(as.matrix(result$random.z)) +nullN <- if (is.null(result$null.z)) 0L else nrow(as.matrix(result$null.z)) +nCond <- if (is.null(result$strong.z)) NA_integer_ else ncol(as.matrix(result$strong.z)) +cat(sprintf("Wrote MASH input (strong=%d, random=%d, null=%d rows x %s conditions) to %s\n", + strongN, randomN, nullN, as.character(nCond), argv$output)) diff --git a/code/script/pecotmr_integration/mash_prior.R b/code/script/pecotmr_integration/mash_prior.R new file mode 100644 index 000000000..bc2010b26 --- /dev/null +++ b/code/script/pecotmr_integration/mash_prior.R @@ -0,0 +1,85 @@ +#!/usr/bin/env Rscript +# mash_prior.R +# +# Estimate the refined MASH prior (covariance list U + mixture weights) via +# pecotmr::mashPriorCovariances -- the unified backing for mixture_prior.ipynb's +# prior-engine steps. Each step fixes a single `--engine`: +# +# --engine cov_ed mashr extreme deconvolution (the exported bovy ED; +# the ed_bovy step). Weights from a final mash() fit. +# --engine ud udr ED update (the ud step). OPT-IN (numerical issues). +# --engine ud_ted udr TED update (the ud_unconstrained step). Needs i.i.d. +# (z-scale) data. +# +# mashPriorCovariances builds the covariance components (canonical / pca / flash +# / flash_nonneg) internally and refines them with the chosen engine; the +# residual correlation (Vhat) enters here (unlike the component step). +# +# Inputs: +# --data MASH input RDS with strong.b / strong.s matrices. +# --engine cov_ed | ud | ud_ted. Default cov_ed. +# --effect-model "EE" (alpha=0) or "EZ" (alpha=1). +# --vhat-data Residual correlation (Vhat) RDS. Optional (default identity). +# --components Comma-separated covariance components to build. +# Default "canonical,pca,flash,flash_nonneg". +# --npc PCs for cov_pca. Default ncol(Bhat) - 1. +# --seed RNG seed. Default 999. +# --output Output prior RDS (list(U, w, loglik)). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +p <- arg_parser("Estimate the refined MASH prior (U, weights) ") +p <- add_argument(p, "--data", type = "character", + help = "MASH input RDS (strong.b / strong.s)") +p <- add_argument(p, "--engine", type = "character", default = "cov_ed", + help = "cov_ed | ud | ud_ted") +p <- add_argument(p, "--effect-model", type = "character", default = "EE", + help = "EE (alpha=0) or EZ (alpha=1)") +p <- add_argument(p, "--vhat-data", type = "character", default = "", + help = "residual correlation (Vhat) RDS") +p <- add_argument(p, "--components", type = "character", + default = "canonical,pca,flash,flash_nonneg", + help = "comma-separated covariance components") +p <- add_argument(p, "--npc", type = "integer", default = NA_integer_, + help = "PCs for cov_pca (default ncol(Bhat) - 1)") +p <- add_argument(p, "--component-files", type = "character", default = "", + help = "comma-separated pre-built covariance-component RDSes to refine (the mixture-prior pipeline: the per-method component steps built these); overrides --components/--npc") +p <- add_argument(p, "--seed", type = "integer", default = 999L, + help = "RNG seed") +p <- add_argument(p, "--output", type = "character", + help = "output prior RDS (list(U, w, loglik))") +argv <- parse_args(p) + +alpha <- if (toupper(argv$effect_model) == "EZ") 1 else 0 +dat <- readRDS(argv$data) + +strong <- qtlSumStatsFromBetaMatrix( + as.matrix(dat$strong.b), as.matrix(dat$strong.s), study = "mash") + +vhat <- if (nzchar(argv$vhat_data)) readRDS(argv$vhat_data) else NULL + +if (nzchar(argv$component_files)) { + # Pipeline mode: refine the components the per-method steps already built. + files <- trimws(strsplit(argv$component_files, "[ ,]+")[[1L]]) + files <- files[nzchar(files)] + priorComponents <- do.call(c, lapply(files, readRDS)) + prior <- mashPriorCovariances(list(strong = strong), alpha = alpha, vhat = vhat, + priorComponents = priorComponents, + engine = argv$engine, setSeed = argv$seed) +} else { + # Self-contained mode: build the components here. + components <- trimws(strsplit(argv$components, "[ ,]+")[[1L]]) + components <- components[nzchar(components)] + nPcs <- if (is.na(argv$npc)) NULL else argv$npc + prior <- mashPriorCovariances(list(strong = strong), alpha = alpha, vhat = vhat, + components = components, engine = argv$engine, + nPcs = nPcs, setSeed = argv$seed) +} + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(prior, argv$output) +cat(sprintf("Wrote MASH prior [engine=%s] (%d U components) to %s\n", + argv$engine, length(prior$U), argv$output)) diff --git a/code/script/pecotmr_integration/mash_sumstats_construct.R b/code/script/pecotmr_integration/mash_sumstats_construct.R index f241f6558..4194d8381 100644 --- a/code/script/pecotmr_integration/mash_sumstats_construct.R +++ b/code/script/pecotmr_integration/mash_sumstats_construct.R @@ -3,15 +3,14 @@ # # Per-region MASH input builder. Reads one or more multi-context tensorqtl # summary-statistics files (one per condition / trait combination) for a -# single LD-block region and writes a per-region RDS in the legacy "dat" -# shape that mash.R consumes: +# single region, inner-joins them on variant_id into a variants x conditions +# z-matrix, and writes a per-region multi-context QtlSumStats RDS (each +# context = one column) via pecotmr::qtlSumStatsFromZMatrix. # -# list( = list(z = )) -# -# The downstream mash.R worker concatenates per-region RDSes, partitions -# into strong / random / null subsets via pecotmr::mashRandNullSample, -# wraps each partition as a QtlSumStats, runs summaryStatsQc, and calls -# pecotmr::mashPipeline. +# The downstream mash_preprocessing.R worker reads the per-region QtlSumStats +# RDSes and calls pecotmr::mashInput, which selects the strong / random / null +# partitions and assembles the mash_input.rds. (ldSketch stays NULL -- mash +# operates across conditions per variant and needs no LD reference.) # # Inputs: # --tensorqtl-paths file1 [file2 ...] Per-condition tensorqtl @@ -21,13 +20,16 @@ # either `z` or `tstat`. # --conditions c1,c2,... Condition labels, same order # and length as --tensorqtl-paths. -# --region chr:start-end Genomic interval label (used -# as the region_id key in the -# output RDS). -# --output Output path. +# --region chr:start-end Genomic interval label (recorded +# in the log; the QtlSumStats keys +# variants by their ids). +# --study Study label for the QtlSumStats. +# Default "mash". +# --output Output QtlSumStats RDS path. suppressPackageStartupMessages({ library(argparser) + library(pecotmr) }) parser <- arg_parser("Build a per-region MASH input RDS from per-condition tensorqtl outputs") @@ -38,10 +40,13 @@ parser <- add_argument(parser, "--conditions", help = "Comma-separated condition labels (one per path)", type = "character") parser <- add_argument(parser, "--region", - help = "Genomic interval as chr:start-end (used as region_id)", + help = "Genomic interval as chr:start-end (log label)", type = "character") +parser <- add_argument(parser, "--study", + help = "Study label for the QtlSumStats", type = "character", + default = "mash") parser <- add_argument(parser, "--output", - help = "Output RDS path", type = "character") + help = "Output QtlSumStats RDS path", type = "character") argv <- parse_args(parser) paths <- as.character(argv$tensorqtl_paths) @@ -92,10 +97,13 @@ if (nrow(zMat) == 0L) stop("No variants left after dropping rows with NA in any condition for region ", argv$region, ".") -out <- list() -out[[argv$region]] <- list(z = zMat, region = argv$region) +# Wrap the region's z-matrix as a multi-context QtlSumStats (one column per +# condition). qtlSumStatsFromZMatrix stamps a non-empty qcInfo, so mashInput() +# accepts it directly; ldSketch stays NULL (mash needs no LD reference). +qss <- qtlSumStatsFromZMatrix(zMat, study = argv$study, context = conditions, + trait = "mash") dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -saveRDS(out, argv$output, compress = "xz") -cat(sprintf("Wrote MASH input for region %s: %d variants x %d conditions to %s\n", +saveRDS(qss, argv$output, compress = "xz") +cat(sprintf("Wrote QtlSumStats for region %s: %d variants x %d conditions to %s\n", argv$region, nrow(zMat), ncol(zMat), argv$output)) diff --git a/code/script/pecotmr_integration/mash_vhat.R b/code/script/pecotmr_integration/mash_vhat.R new file mode 100644 index 000000000..6921b4d0f --- /dev/null +++ b/code/script/pecotmr_integration/mash_vhat.R @@ -0,0 +1,72 @@ +#!/usr/bin/env Rscript +# mash_vhat.R +# +# Learn the MASH residual correlation matrix (Vhat) via +# pecotmr::mashResidualCorrelation. Unified backing for mixture_prior.ipynb's +# `vhat_*` steps: each step fixes a single `--method`, demonstrating that +# estimator on the same input. +# +# --method identity diag(nConditions) +# --method simple estimate_null_correlation_simple on the null set +# --method mle mash_estimate_corr_em on a random subset (needs +# --prior-data, the prior $U) +# --method corshrink CorShrink adaptive-shrinkage null correlation +# --method simple_specific nearPD(cov(nullZ), corr = TRUE) +# +# Inputs: +# --data MASH input RDS with strong.b/random.b/null.b (+ .s) matrices. +# --method Estimator (see above). Default "simple". +# --effect-model "EE" (alpha=0) or "EZ" (alpha=1). +# --prior-data Prior RDS carrying a $U list (required by --method mle). +# --n-subset mle random-subset size. Default 6000. +# --max-iter mle EM iterations. Default 6. +# --output Output Vhat RDS (a conditions x conditions matrix). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) +}) + +p <- arg_parser("Estimate the MASH residual correlation (Vhat)") +p <- add_argument(p, "--data", type = "character", + help = "MASH input RDS (strong.b/random.b/null.b + .s)") +p <- add_argument(p, "--method", type = "character", default = "simple", + help = "identity | simple | mle | corshrink | simple_specific") +p <- add_argument(p, "--effect-model", type = "character", default = "EE", + help = "EE (alpha=0) or EZ (alpha=1)") +p <- add_argument(p, "--prior-data", type = "character", default = "", + help = "prior RDS with $U (required for --method mle)") +p <- add_argument(p, "--n-subset", type = "integer", default = 6000L, + help = "mle random-subset size") +p <- add_argument(p, "--max-iter", type = "integer", default = 6L, + help = "mle EM iterations") +p <- add_argument(p, "--output", type = "character", help = "output Vhat RDS") +argv <- parse_args(p) + +alpha <- if (toupper(argv$effect_model) == "EZ") 1 else 0 +dat <- readRDS(argv$data) + +# Wrap whichever partitions are present as beta-scale QtlSumStats (no LD). +mk <- function(bKey, sKey) { + if (is.null(dat[[bKey]])) return(NULL) + qtlSumStatsFromBetaMatrix(as.matrix(dat[[bKey]]), as.matrix(dat[[sKey]]), + study = "mash") +} +ssl <- Filter(Negate(is.null), list( + strong = mk("strong.b", "strong.s"), + random = mk("random.b", "random.s"), + null = mk("null.b", "null.s"))) + +U <- if (nzchar(argv$prior_data)) { + pr <- readRDS(argv$prior_data) + if (is.list(pr) && !is.null(pr$U)) pr$U else pr +} else NULL + +vhat <- mashResidualCorrelation(ssl, alpha = alpha, method = argv$method, + priorCovariances = U, + nSubset = argv$n_subset, maxIter = argv$max_iter) + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(vhat, argv$output) +cat(sprintf("Wrote Vhat [method=%s] (%d x %d) to %s\n", + argv$method, nrow(vhat), ncol(vhat), argv$output)) diff --git a/code/script/pecotmr_integration/qtl_association_postprocessing.R b/code/script/pecotmr_integration/qtl_association_postprocessing.R new file mode 100644 index 000000000..6dc94dd73 --- /dev/null +++ b/code/script/pecotmr_integration/qtl_association_postprocessing.R @@ -0,0 +1,187 @@ +#!/usr/bin/env Rscript +# qtl_association_postprocessing.R +# +# Hierarchical multiple-testing correction of cis-QTL association results +# (TensorQTL), via pecotmr::qtlAssociationPostprocess. This is the thin wrapper +# that replaces the old notebook's `source(pecotmr/inst/code/tensorqtl_postprocessor.R)` +# pattern: it does the file I/O (read the per-gene regional + per-variant pairs, +# p-value pre-filter, join the filtered variant counts), assembles a per-gene +# QtlSumStats (one ROW per gene; each ENTRY the gene's variants), calls the +# pecotmr correction engine, and writes the consolidated RDS + the per-method +# regional / significant-QTL / significant-event / summary tables. All the +# multiple-testing statistics live in pecotmr (p.adjust / qvalue / qbeta). +# +# Inputs (one chromosome / batch per call): +# --regional per-gene TensorQTL regional summary. Needs +# molecular_trait_object_id, n_variants, beta_shape1, +# beta_shape2, p_beta (genetic-effect flavour). +# --pairs per-variant TensorQTL cis pairs. Needs +# molecular_trait_object_id, variant_id, chrom, pos, +# , , tss_distance, tes_distance, +# and (optionally) qvalue. +# --n-variants-stats optional per-gene n_variants_filtered (else the +# filtered Bonferroni flavour is skipped). +# Params mirror the legacy CLI: --maf-cutoff / --cis-window / --fdr-threshold / +# --pvalue-cutoff / --pvalue-col / --af-col / --study / --context / --genome. +# Outputs: +# --output the enriched QtlSumStats (consolidated correction object). +# --output-dir optional: flat per-method tables (regional / significant +# QTL / significant events / summary). + +suppressPackageStartupMessages({ + library(argparser) + library(pecotmr) + library(readr) + library(GenomicRanges) + library(IRanges) + library(S4Vectors) +}) + +p <- arg_parser("cis-QTL association postprocessing via pecotmr::qtlAssociationPostprocess") +p <- add_argument(p, "--regional", help = "per-gene regional tsv(.gz)", type = "character", default = NA) +p <- add_argument(p, "--pairs", help = "per-variant pairs tsv(.gz)", type = "character", default = NA) +p <- add_argument(p, "--n-variants-stats", help = "per-gene n_variants_filtered tsv(.gz)", + type = "character", default = NA) +# Legacy CLI: glob the inputs from a work dir by (regex) pattern instead of +# passing explicit paths. +p <- add_argument(p, "--cwd", help = "work dir to glob inputs from", type = "character", default = NA) +p <- add_argument(p, "--regional-pattern", help = "regex for the regional file in --cwd", type = "character", default = NA) +p <- add_argument(p, "--qtl-pattern", help = "regex for the pairs file in --cwd", type = "character", default = NA) +p <- add_argument(p, "--n-variants-suffix", help = "regex for the n_variants stats file in --cwd", type = "character", default = NA) +p <- add_argument(p, "--maf-cutoff", help = "MAF cutoff (filtered Bonferroni)", type = "numeric", default = 0) +p <- add_argument(p, "--cis-window", help = "cis-window bp (filtered Bonferroni)", type = "numeric", default = 0) +p <- add_argument(p, "--fdr-threshold", help = "FDR threshold", type = "numeric", default = 0.05) +p <- add_argument(p, "--pvalue-cutoff", help = "pre-filter pairs to p < cutoff", type = "numeric", default = 1) +p <- add_argument(p, "--pvalue-col", help = "pairs p-value column", type = "character", default = "pvalue") +p <- add_argument(p, "--af-col", help = "pairs allele-frequency column", type = "character", default = "af") +p <- add_argument(p, "--study", help = "study label", type = "character", default = "study") +p <- add_argument(p, "--context", help = "context label", type = "character", default = "context") +p <- add_argument(p, "--genome", help = "genome build", type = "character", default = "hg38") +p <- add_argument(p, "--output", help = "output QtlSumStats RDS", type = "character") +p <- add_argument(p, "--output-dir", help = "optional dir for flat per-method tables", + type = "character", default = NA) +argv <- parse_args(p) + +idCol <- "molecular_trait_object_id" +# Resolve each input: an explicit --path, or the first match of a regex pattern +# in --cwd (the legacy glob CLI). +resolveOne <- function(explicit, cwd, pattern, what) { + if (!is.na(explicit)) return(explicit) + if (is.na(cwd) || is.na(pattern)) return(NA_character_) + hits <- list.files(cwd, pattern = pattern, full.names = TRUE) + if (length(hits) == 0L) stop("No ", what, " file matching '", pattern, "' in ", cwd) + hits[1L] +} +regionalFile <- resolveOne(argv$regional, argv$cwd, argv$regional_pattern, "regional") +pairsFile <- resolveOne(argv$pairs, argv$cwd, argv$qtl_pattern, "pairs") +nvFile <- resolveOne(argv$n_variants_stats, argv$cwd, argv$n_variants_suffix, "n_variants") +if (is.na(regionalFile) || is.na(pairsFile)) + stop("Provide --regional/--pairs, or --cwd with --regional-pattern/--qtl-pattern.") +regional <- readr::read_tsv(regionalFile, show_col_types = FALSE, progress = FALSE) +pairs <- readr::read_tsv(pairsFile, show_col_types = FALSE, progress = FALSE) +if (!(idCol %in% names(regional)) || !("p_beta" %in% names(regional))) + stop("--regional must carry ", idCol, " and p_beta.") +if (!(idCol %in% names(pairs)) || !(argv$pvalue_col %in% names(pairs))) + stop("--pairs must carry ", idCol, " and the p-value column '", argv$pvalue_col, "'.") + +# p-value pre-filter (keeps the object small; the per-gene min variant is always +# retained so the Bonferroni min is exact). +if (argv$pvalue_cutoff < 1) + pairs <- pairs[!is.na(pairs[[argv$pvalue_col]]) & pairs[[argv$pvalue_col]] < argv$pvalue_cutoff, ] + +nvFilt <- NULL +if (!is.na(nvFile)) { + nvs <- readr::read_tsv(nvFile, show_col_types = FALSE, progress = FALSE) + nvFilt <- setNames(nvs$n_variants_filtered, nvs[[idCol]]) +} + +genes <- as.character(regional[[idCol]]) +pairsByGene <- split(pairs, factor(pairs[[idCol]], levels = genes)) + +mkEntry <- function(g) { + d <- pairsByGene[[g]] + if (is.null(d) || nrow(d) == 0L) return(GenomicRanges::GRanges()) + chrom <- paste0("chr", sub("^chr", "", as.character(d$chrom))) + gr <- GenomicRanges::GRanges(chrom, IRanges::IRanges(as.integer(d$pos), width = 1L)) + mc <- S4Vectors::DataFrame( + SNP = as.character(d$variant_id), + P = as.numeric(d[[argv$pvalue_col]]), + af = as.numeric(d[[argv$af_col]]), + tss_distance = as.numeric(d$tss_distance), + tes_distance = as.numeric(d$tes_distance)) + if ("qvalue" %in% names(d)) mc$qvalue <- as.numeric(d$qvalue) + S4Vectors::mcols(gr) <- mc + gr +} +entries <- lapply(genes, mkEntry) + +nVar <- as.numeric(regional$n_variants) +nVarFcol <- if (!is.null(nvFilt)) as.numeric(nvFilt[genes]) else NULL + +qssArgs <- list( + study = rep(argv$study, length(genes)), context = rep(argv$context, length(genes)), + trait = genes, entry = entries, genome = argv$genome, + n_variants = nVar, p_beta = as.numeric(regional$p_beta), + beta_shape1 = as.numeric(regional$beta_shape1), + beta_shape2 = as.numeric(regional$beta_shape2)) +if (!is.null(nVarFcol)) qssArgs$n_variants_filtered <- nVarFcol +qss <- do.call(QtlSumStats, qssArgs) + +filtering <- (argv$maf_cutoff > 0 || argv$cis_window > 0) && !is.null(nVarFcol) +r <- qtlAssociationPostprocess( + qss, fdrThreshold = argv$fdr_threshold, + mafCutoff = if (filtering) argv$maf_cutoff else 0, + cisWindow = if (filtering) argv$cis_window else 0, + methods = c("permutation", "bonferroni")) + +dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) +saveRDS(r, argv$output) +cat(sprintf("Wrote enriched QtlSumStats (%d genes) to %s\n", nrow(r), argv$output)) + +# ---- optional flat per-method exports ---- +if (!is.na(argv$output_dir)) { + od <- argv$output_dir + dir.create(od, showWarnings = FALSE, recursive = TRUE) + base <- sub("\\.[^.]*$", "", basename(argv$output)) + + # Enriched regional = input regional + the correction columns (row order kept). + newCols <- setdiff(names(r), c(names(regional), "study", "context", "trait", + "entry", "varY", "traitPos")) + regionalOut <- cbind(as.data.frame(regional), + as.data.frame(S4Vectors::as.data.frame(r[, newCols, drop = FALSE]))) + readr::write_tsv(regionalOut, file.path(od, paste0(base, ".cis_regional.fdr.tsv.gz"))) + + # Per-method EVENT-significance column (which genes pass): permutation and the + # q-value SNP method gate events on the Storey q of the beta-approx permutation + # p (q_beta); Bonferroni gates on its BH-FDR of the per-gene min. This matches + # the variant-level rules getSignificantQtls() applies. + flavours <- c(permutation = "q_beta", + bonferroni_original = "fdr_bonferroni_min_original", + bonferroni_filtered = "fdr_bonferroni_min_filtered", + qvalue = "q_beta") + summary_rows <- list() + for (m in names(flavours)) { + fcol <- flavours[[m]] + if (is.null(r[[fcol]])) next + # significant events (per-gene) at the FDR threshold + keep <- !is.na(r[[fcol]]) & as.numeric(r[[fcol]]) < argv$fdr_threshold + events <- regionalOut[keep, , drop = FALSE] + if (nrow(events) > 0) + readr::write_tsv(events, file.path(od, paste0(base, ".significant_events.", m, ".tsv.gz"))) + # significant variant-level QTL (derived, never stored) + sig <- tryCatch(getSignificantQtls(r, m, threshold = argv$fdr_threshold), + error = function(e) NULL) + nqtl <- 0L + if (!is.null(sig) && length(sig) > 0) { + sdf <- as.data.frame(sig) + readr::write_tsv(sdf, file.path(od, paste0(base, ".significant_qtl.", m, ".tsv.gz"))) + nqtl <- length(sig) + } + summary_rows[[m]] <- data.frame(method = m, significant_events = sum(keep), + significant_qtl = nqtl) + } + if (length(summary_rows) > 0) + readr::write_tsv(do.call(rbind, summary_rows), + file.path(od, paste0(base, ".summary.tsv"))) + cat(sprintf("Wrote flat per-method tables to %s\n", od)) +} diff --git a/code/script/pecotmr_integration/qtl_dataset_construct.R b/code/script/pecotmr_integration/qtl_dataset_construct.R index cc387386e..b3c60f9a6 100644 --- a/code/script/pecotmr_integration/qtl_dataset_construct.R +++ b/code/script/pecotmr_integration/qtl_dataset_construct.R @@ -42,9 +42,6 @@ suppressPackageStartupMessages({ library(argparser) library(pecotmr) - library(SummarizedExperiment) - library(GenomicRanges) - library(S4Vectors) }) parser <- arg_parser("Build a pecotmr QtlDataset for one study and save to RDS") @@ -89,159 +86,56 @@ parser <- add_argument(parser, "--output", help = "Output RDS path", type = "character") argv <- parse_args(parser) -# ----- File readers --------------------------------------------------------- -read_pheno_bed <- function(path) { - read.table(gzfile(path), header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, - comment.char = "") -} - -# Read a covariate TSV. Default expects samples-as-rows + PC columns. -# With transpose = TRUE, expects QTLtools-format input (covariates as rows, -# samples as columns) and transposes to samples-as-rows. -read_pcs_tsv <- function(path, transpose = FALSE) { - raw <- read.table(path, header = TRUE, sep = "\t", row.names = 1, - check.names = FALSE, comment.char = "") - m <- as.matrix(raw) - if (transpose) m <- t(m) - m -} - -# ----- Manifest ingestion --------------------------------------------------- -manifest <- read.table(argv$phenotype_manifest, header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, - comment.char = "") -required <- c("ID", "path", "cond") -missingCols <- setdiff(required, names(manifest)) -if (length(missingCols) > 0L) { - stop("--phenotype-manifest missing required column(s): ", - paste(missingCols, collapse = ", ")) -} -has_cov_col <- "cov_path" %in% names(manifest) - -# Resolve manifest-relative paths against the manifest's own directory. -manifest_dir <- dirname(normalizePath(argv$phenotype_manifest)) -resolve_path <- function(p) { - if (is.na(p) || !nzchar(p)) return("") - if (startsWith(p, "/")) return(p) - file.path(manifest_dir, p) -} - -# Collapse to one (phenotype, cov_path) pair per context. Multiple rows per -# context (different traits) must agree on the file paths. -contexts <- unique(manifest$cond) -phenotype_files <- list() -pheno_cov_files <- list() -for (cx in contexts) { - sub <- manifest[manifest$cond == cx, , drop = FALSE] - paths_here <- unique(sub$path) - if (length(paths_here) > 1L) { - stop(sprintf( - "Context '%s' references multiple phenotype paths: %s.", - cx, paste(paths_here, collapse = ", "))) - } - phenotype_files[[cx]] <- paths_here[[1L]] - if (has_cov_col) { - covs_here <- unique(sub$cov_path[!is.na(sub$cov_path) & - nzchar(sub$cov_path)]) - if (length(covs_here) > 1L) { - stop(sprintf( - "Context '%s' references multiple cov_path values: %s.", - cx, paste(covs_here, collapse = ", "))) - } - pheno_cov_files[[cx]] <- if (length(covs_here) == 1L) covs_here[[1L]] - else "" - } else { - pheno_cov_files[[cx]] <- "" - } -} - -# ----- Per-context SummarizedExperiment builder ----------------------------- -build_se <- function(bed_path, pcov_path, transpose_cov) { - bed <- read_pheno_bed(bed_path) - chr_col <- intersect(c("#chr", "chrom", "chr"), names(bed))[1L] - start_col <- intersect(c("start", "Start"), names(bed))[1L] - end_col <- intersect(c("end", "End"), names(bed))[1L] - gene_col <- intersect(c("gene_id", "ID", - "phenotype_id"), names(bed))[1L] - if (any(is.na(c(chr_col, start_col, end_col, gene_col)))) - stop("Missing one of chrom/start/end/gene_id columns in: ", bed_path) - - meta <- bed[, c(chr_col, start_col, end_col, gene_col)] - names(meta) <- c("chrom", "start", "end", "gene_id") - sample_cols <- setdiff(names(bed), - c("#chr", "chrom", "chr", "start", "Start", "end", "End", - "gene_id", "ID", "phenotype_id", "strand", "Strand")) - - expr <- as.matrix(bed[, sample_cols, drop = FALSE]) - storage.mode(expr) <- "double" - rownames(expr) <- meta$gene_id - - rr <- GRanges(seqnames = meta$chrom, - ranges = IRanges(start = meta$start + 1L, end = meta$end)) - names(rr) <- meta$gene_id - - cd <- if (nzchar(pcov_path)) { - pcov <- read_pcs_tsv(pcov_path, transpose = transpose_cov) - common <- intersect(rownames(pcov), colnames(expr)) - if (length(common) == 0L) - stop("No shared samples between phenotype and phenotype-covariate: ", - bed_path) - expr <- expr[, common, drop = FALSE] - DataFrame(pcov[common, , drop = FALSE], row.names = common) - } else { - DataFrame(row.names = colnames(expr)) - } - SummarizedExperiment(assays = list(expression = expr), - rowRanges = rr, - colData = cd) -} - -phenotypes <- setNames( - lapply(contexts, function(cx) - build_se(resolve_path(phenotype_files[[cx]]), - resolve_path(pheno_cov_files[[cx]]), - argv$transpose_covariates)), - contexts) - -# ----- Genotype handle (PLINK1) + uniform genotype covariates --------------- -geno_handle <- GenotypeHandle(plink1Prefix = argv$genotype_prefix) - -geno_cov_path <- argv$genotype_covariates -has_geno_cov <- nzchar(geno_cov_path) && geno_cov_path != "." && - file.exists(geno_cov_path) -genoCov <- if (has_geno_cov) { - read_pcs_tsv(geno_cov_path, transpose = argv$transpose_covariates) -} else { - matrix(numeric(0), nrow = 0, ncol = 0) -} - -# ----- Construct + save ------------------------------------------------------ +# Read a whitespace-delimited ID file into a unique character vector; empty +# (or "." / missing) yields character(0), i.e. "keep all" in QtlDataset(). read_id_file <- function(p) if (nzchar(p) && p != "." && file.exists(p)) unique(trimws(unlist(strsplit(readLines(p), "[[:space:]]+")))) else character(0) keep_samples <- read_id_file(argv$keep_samples) keep_variants <- read_id_file(argv$keep_variants) -qd_args <- list( - study = argv$study, - genotypes = geno_handle, - phenotypes = phenotypes, - genotypeCovariates = genoCov, - mafCutoff = argv$maf_cutoff, - macCutoff = argv$mac_cutoff, - xvarCutoff = argv$xvar_cutoff, - imissCutoff = argv$imiss_cutoff, - keepIndel = !isTRUE(argv$drop_indel), - scaleResiduals = !isTRUE(argv$no_scale_residuals)) -# keepSamples / keepVariants only when a file was given (else the constructor -# default = keep all). -if (length(keep_samples) > 0L) qd_args$keepSamples <- keep_samples -if (length(keep_variants) > 0L) qd_args$keepVariants <- keep_variants -qd <- do.call(QtlDataset, qd_args) +# Absolutise a (possibly non-existent, e.g. a PLINK prefix) path against CWD. +# normalizePath() alone won't absolutise a path with no file on disk, so +# resolve the (existing) parent directory and re-attach the basename. +abs_path <- function(p) file.path(normalizePath(dirname(p), mustWork = FALSE), + basename(p)) + +# Genotype covariates: pass the path through to the loader (which reads and, +# when --transpose-covariates is set, transposes it); NULL when unset. +# Absolutise so the loader does not re-resolve it against the manifest's own +# directory (the --genotype-* args are CWD-relative, not manifest-relative). +geno_cov_path <- argv$genotype_covariates +genotype_covariates <- if (nzchar(geno_cov_path) && geno_cov_path != "." && + file.exists(geno_cov_path)) + abs_path(geno_cov_path) else NULL + +# Absolutise the genotype prefix for the same reason (the loader resolves a +# character genotype spec against the manifest directory). +genotype_prefix <- abs_path(argv$genotype_prefix) + +# All manifest ingestion, per-context phenotype/covariate assembly, genotype +# handling, and QtlDataset construction now live in pecotmr's manifest loader. +# The manifest's cond/path/cov_path columns are recognised via the loader's +# snake_case aliases (cond -> context, path -> phenotypePath, +# cov_path -> covariatePath). +qd <- loadQtlDatasetFromManifest( + manifest = argv$phenotype_manifest, + study = argv$study, + genotypes = genotype_prefix, + genotypeCovariates = genotype_covariates, + scaleResiduals = !isTRUE(argv$no_scale_residuals), + mafCutoff = argv$maf_cutoff, + macCutoff = argv$mac_cutoff, + xvarCutoff = argv$xvar_cutoff, + imissCutoff = argv$imiss_cutoff, + keepSamples = keep_samples, + keepVariants = keep_variants, + keepIndel = !isTRUE(argv$drop_indel), + transposeCovariates = isTRUE(argv$transpose_covariates)) dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) saveRDS(qd, argv$output) +contexts <- getContexts(qd) cat(sprintf("Wrote QtlDataset for study '%s' (%d contexts: %s) to %s\n", - argv$study, length(phenotypes), - paste(names(phenotypes), collapse = ", "), + argv$study, length(contexts), + paste(contexts, collapse = ", "), argv$output)) diff --git a/code/script/pecotmr_integration/qtl_enrichment.R b/code/script/pecotmr_integration/qtl_enrichment.R index aea5acfbb..682859d72 100644 --- a/code/script/pecotmr_integration/qtl_enrichment.R +++ b/code/script/pecotmr_integration/qtl_enrichment.R @@ -26,11 +26,11 @@ suppressPackageStartupMessages({ parser <- arg_parser("xQTL-GWAS enrichment via qtlEnrichmentPipeline()") parser <- add_argument(parser, "--qtl-fine-mapping", - help = "Path to S4 QtlFineMappingResult RDS", - type = "character") + help = "Path(s) to S4 QtlFineMappingResult RDS (combined if >1)", + type = "character", nargs = Inf) parser <- add_argument(parser, "--gwas-fine-mapping", - help = "Path to S4 GwasFineMappingResult RDS", - type = "character") + help = "Path(s) to S4 GwasFineMappingResult RDS (combined if >1)", + type = "character", nargs = Inf) parser <- add_argument(parser, "--num-gwas", help = "Number of GWAS variants (per study; pass-through)", type = "numeric", default = NA) @@ -50,8 +50,19 @@ parser <- add_argument(parser, "--output", help = "Output RDS path", type = "character") argv <- parse_args(parser) -qtlFmr <- readRDS(argv$qtl_fine_mapping) -gwasFmr <- readRDS(argv$gwas_fine_mapping) +# Load one-or-more FineMappingResult RDS(es) and combine (the modern pipeline +# supplies per-study/per-block FMRs directly, replacing the legacy converter's +# multi --rds-files combine step). +.loadCombine <- function(paths) { + fmrs <- lapply(as.character(paths), readRDS) + if (length(fmrs) == 1L) return(fmrs[[1L]]) + # Preserve the (shared) ldSketch: combineFineMappingResults defaults it to + # NULL, but gwas enrichment/coloc require the RSS-derived ldSketch. + ld <- tryCatch(fmrs[[1L]]@ldSketch, error = function(e) NULL) + do.call(combineFineMappingResults, c(fmrs, list(ldSketch = ld))) +} +qtlFmr <- .loadCombine(argv$qtl_fine_mapping) +gwasFmr <- .loadCombine(argv$gwas_fine_mapping) res <- qtlEnrichmentPipeline( gwasFineMappingResult = gwasFmr, diff --git a/code/script/pecotmr_integration/region_manifest.R b/code/script/pecotmr_integration/region_manifest.R index 1b13b8331..6b3244411 100644 --- a/code/script/pecotmr_integration/region_manifest.R +++ b/code/script/pecotmr_integration/region_manifest.R @@ -53,18 +53,15 @@ parser <- add_argument(parser, "--output", help = "Output manifest TSV path", type = "character") argv <- parse_args(parser) -norm_chr <- function(x) { - x <- as.character(x) - ifelse(is.na(x) | !nzchar(x), x, - ifelse(startsWith(x, "chr"), x, paste0("chr", x))) -} +.d <- dirname(sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +source(file.path(.d, "manifest_common.R")) + # ----- Gene coordinates from the phenotype manifest ------------------------- if (is.null(argv$pheno_manifest) || !nzchar(argv$pheno_manifest) || !file.exists(argv$pheno_manifest)) stop("--pheno-manifest is required and must exist: ", argv$pheno_manifest) -pm <- read.table(argv$pheno_manifest, header = TRUE, sep = "\t", - stringsAsFactors = FALSE, check.names = FALSE, comment.char = "") +pm <- readMeta(argv$pheno_manifest) id_col <- intersect(c("ID", "gene_id", "phenotype_id"), names(pm))[1L] chr_col <- intersect(c("#chr", "chrom", "chr"), names(pm))[1L] start_col <- intersect(c("start", "Start"), names(pm))[1L] @@ -73,7 +70,7 @@ if (any(is.na(c(id_col, chr_col, start_col, end_col)))) stop("--pheno-manifest needs ID, #chr/chrom, start, end columns (got: ", paste(names(pm), collapse = ", "), ").") genes <- as.character(pm[[id_col]]) -gchr <- norm_chr(pm[[chr_col]]) +gchr <- chromAdd(pm[[chr_col]]) gstart <- suppressWarnings(as.integer(pm[[start_col]])) gend <- suppressWarnings(as.integer(pm[[end_col]])) uniqGenes <- unique(genes) @@ -90,11 +87,10 @@ windowOrder <- character(0) if (nzchar(argv$customized_association_windows) && argv$customized_association_windows != "." && file.exists(argv$customized_association_windows)) { - caw <- read.table(argv$customized_association_windows, header = FALSE, - sep = "", stringsAsFactors = FALSE, comment.char = "#") + caw <- readTableNoHeader(argv$customized_association_windows) for (i in seq_len(nrow(caw))) { rid <- as.character(caw[[4L]][[i]]) - windows[[rid]] <- list(chr = norm_chr(caw[[1L]][[i]]), + windows[[rid]] <- list(chr = chromAdd(caw[[1L]][[i]]), start = as.integer(caw[[2L]][[i]]), end = as.integer(caw[[3L]][[i]])) windowOrder <- c(windowOrder, rid) @@ -154,8 +150,6 @@ if (length(rows) == 0L) "--customized-association-windows against the phenotype manifest.") out <- do.call(rbind, rows) -dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) -write.table(out, file = argv$output, sep = "\t", quote = FALSE, - row.names = FALSE, na = "") +writeManifest(out, argv$output) cat(sprintf("Wrote region manifest with %d region(s) to %s\n", nrow(out), argv$output)) diff --git a/code/script/pecotmr_integration/sldsc_meta_subset.R b/code/script/pecotmr_integration/sldsc_meta_subset.R index b905e0db6..856c5f175 100644 --- a/code/script/pecotmr_integration/sldsc_meta_subset.R +++ b/code/script/pecotmr_integration/sldsc_meta_subset.R @@ -41,31 +41,14 @@ res <- readRDS(argv$postprocess_rds) subsetTraits <- readLines(argv$subset_traits_file) subsetTraits <- subsetTraits[nzchar(trimws(subsetTraits))] +# When --target-categories is empty, sldscSubsetMeta falls back to +# params$target_categories. The view-building, the per-category metaSldscRandom +# grid, and the missing-trait check all live in pecotmr::sldscSubsetMeta. targetCats <- if (nzchar(argv$target_categories)) { trimws(strsplit(argv$target_categories, ",", fixed = TRUE)[[1L]]) -} else res$params$target_categories +} else NULL -missingTraits <- setdiff(subsetTraits, names(res$per_trait)) -if (length(missingTraits) > 0L) - stop("--subset-traits-file names traits absent from --postprocess-rds: ", - paste(missingTraits, collapse = ", ")) - -subsetPerTrait <- res$per_trait[subsetTraits] - -# Map the wide per-trait columns (tauStarSingle/tauStarJoint, ...) to the bare -# names metaSldscRandom() expects. -viewSingle <- pecotmr:::.sldscViewForMeta(subsetPerTrait, "single") -viewJoint <- pecotmr:::.sldscViewForMeta(subsetPerTrait, "joint") - -out <- list( - tau_star_single = setNames(lapply(targetCats, function(cat) - metaSldscRandom(viewSingle, cat, "tauStar")), targetCats), - tau_star_joint = setNames(lapply(targetCats, function(cat) - metaSldscRandom(viewJoint, cat, "tauStar")), targetCats), - enrichment = setNames(lapply(targetCats, function(cat) - metaSldscRandom(viewSingle, cat, "enrichment")), targetCats), - enrichstat = setNames(lapply(targetCats, function(cat) - metaSldscRandom(viewSingle, cat, "enrichstat")), targetCats)) +out <- sldscSubsetMeta(res, subsetTraits, targetCategories = targetCats) dir.create(dirname(argv$output), showWarnings = FALSE, recursive = TRUE) saveRDS(out, argv$output) diff --git a/code/script/pecotmr_integration/sldsc_postprocess.R b/code/script/pecotmr_integration/sldsc_postprocess.R index 66e2e60c4..89e49f819 100644 --- a/code/script/pecotmr_integration/sldsc_postprocess.R +++ b/code/script/pecotmr_integration/sldsc_postprocess.R @@ -121,12 +121,13 @@ traitList <- setNames(lapply(traits, function(t) { annot <- readSldscAnnot(argv$target_anno_dir) frq <- NULL if (argv$maf_cutoff > 0) { - if (!nzchar(argv$frqfile_dir)) + # frq is only needed for MAF filtering; --maf-cutoff 0 opts out entirely (per + # the doc above), so it is NOT read at cutoff 0 even if --frqfile-dir is set + # (the notebook passes the empty default "." there). + if (!nzchar(argv$frqfile_dir) || argv$frqfile_dir == ".") stop("--maf-cutoff = ", argv$maf_cutoff, " requires --frqfile-dir (frq data needed for MAF filtering).") frq <- readSldscFrq(argv$frqfile_dir, plinkName = argv$plink_name) -} else if (nzchar(argv$frqfile_dir)) { - frq <- readSldscFrq(argv$frqfile_dir, plinkName = argv$plink_name) } sldscData <- SldscData(annot = annot, frq = frq, traits = traitList) diff --git a/code/script/pecotmr_integration/twas_manifest.R b/code/script/pecotmr_integration/twas_manifest.R new file mode 100644 index 000000000..9e5514ada --- /dev/null +++ b/code/script/pecotmr_integration/twas_manifest.R @@ -0,0 +1,205 @@ +#!/usr/bin/env Rscript +# twas_manifest.R +# +# Resolve twas_ctwas.ipynb's per-region TWAS analysis units into a manifest TSV, +# so the [twas] / [ctwas] / [quantile_twas] steps can fan out over its rows with +# inline csv.DictReader (no notebook-local Python / pandas). This replaces the +# in-notebook get_analysis_regions / extract_regional_data pandas machinery. +# +# One row per analysis region that carries >=1 overlapping xQTL weight. A +# "region" is a coarse genomic window (an LD-reference block, or a +# region_name entry); the [twas] step builds ONE GwasSumStats per region and +# reuses it across the region's genes (a fan-out convenience, not cTWAS +# placement -- gene -> home-LD-block placement is done inside pecotmr's +# assembleCtwasInputs from the weight `region` provenance). +# +# Gene <-> region mapping here is the legacy TSS-overlap binning +# (extract_regional_data): an xQTL weight belongs to a region when it is on the +# region's chromosome and its TSS falls within [start, stop]. Meta-referenced +# file paths are resolved with the legacy adapt_file_path rule (exists as given +# -> basename in cwd -> basename in the meta's dir -> meta_dir/path). +# +# NOTE: no data-layout path is hardcoded; every path comes from arguments or is +# resolved relative to the meta file that referenced it. +# +# Inputs: +# --gwas-meta GWAS metadata TSV (study_id, chrom, file_path[, column_mapping_file]). +# chrom 0 expands to chromosomes 1..22. +# --xqtl-meta xQTL weight metadata TSV (region_id, #chr, start, end, TSS, +# original_data[, contexts]); original_data is a comma-separated +# list of weight RDS paths; region_id is the gene name. +# --regions Optional BED-like TSV of analysis regions (chr, start, stop). +# --region-name Optional comma-separated "chr_start_stop" regions. When given, +# these REPLACE --regions (matching the legacy behaviour). +# --gwas-name / --gwas-data / --column-mapping Optional parallel vectors of +# inline GWAS studies not listed in --gwas-meta (study name, +# sumstats path, optional column-mapping path). Applied to every +# region (covering all chromosomes). +# --output Output manifest TSV path. +# +# Output columns (one row per region): region_id, chrom, start, stop, genes, +# weight_files, gwas_studies, gwas_files, gwas_mappings. The comma-separated +# `genes` and `weight_files` are position-parallel (a gene repeats once per +# weight file); `gwas_studies`, `gwas_files`, `gwas_mappings` are likewise +# position-parallel. + +suppressPackageStartupMessages({ + library(argparser) +}) + +p <- arg_parser("Resolve per-region TWAS analysis units into a manifest TSV") +p <- add_argument(p, "--gwas-meta", type = "character", + help = "GWAS metadata TSV (study_id, chrom, file_path)") +p <- add_argument(p, "--xqtl-meta", type = "character", + help = "xQTL weight metadata TSV (region_id, #chr, start, end, TSS, original_data)") +p <- add_argument(p, "--regions", type = "character", default = "", + help = "Optional BED-like TSV of analysis regions (chr, start, stop)") +p <- add_argument(p, "--region-name", type = "character", default = "", + help = "Optional comma-separated 'chr_start_stop' regions (replace --regions)") +p <- add_argument(p, "--gwas-name", type = "character", nargs = Inf, + default = NA_character_, help = "Optional inline GWAS study names") +p <- add_argument(p, "--gwas-data", type = "character", nargs = Inf, + default = NA_character_, help = "Optional inline GWAS sumstats paths") +p <- add_argument(p, "--column-mapping", type = "character", nargs = Inf, + default = NA_character_, help = "Optional inline GWAS column-mapping paths") +p <- add_argument(p, "--output", type = "character", help = "Output manifest TSV path") +argv <- parse_args(p) + +.d <- dirname(sub("^--file=", "", grep("^--file=", commandArgs(FALSE), value = TRUE)[1L])) +source(file.path(.d, "manifest_common.R")) + +checkCols <- function(df, required, what) { + missing <- setdiff(required, names(df)) + if (length(missing) > 0L) + stop(what, " missing required column(s): ", paste(missing, collapse = ", "), + " (got: ", paste(names(df), collapse = ", "), ")") +} + +splitVec <- function(x) { + # normalise an nargs=Inf argument (NA / length-0 / whitespace) to a clean vector + if (length(x) == 0L) return(character(0)) + x <- x[!is.na(x)] + x <- trimws(x) + x[nzchar(x)] +} + +# ---- inline GWAS vectors (retain the legacy CLI) --------------------------- +gwasName <- splitVec(argv$gwas_name) +gwasData <- splitVec(argv$gwas_data) +colMap <- splitVec(argv$column_mapping) +if (length(gwasName) != length(gwasData)) + stop("--gwas-name and --gwas-data must have equal length") +if (length(colMap) > 0L && length(colMap) != length(gwasName)) + stop("--column-mapping, if given, must match --gwas-name / --gwas-data length") + +# ---- GWAS metadata: (study, chrom) -> [file, mapping] ---------------------- +if (is.null(argv$gwas_meta) || !nzchar(argv$gwas_meta) || !file.exists(argv$gwas_meta)) + stop("--gwas-meta is required and must exist: ", argv$gwas_meta) +gwasDf <- readMeta(argv$gwas_meta) +checkCols(gwasDf, c("study_id", "chrom", "file_path"), "--gwas-meta") +hasMapCol <- "column_mapping_file" %in% names(gwasDf) + +# gwasByChrom[[chrom]] = data.frame(study, file, mapping) of studies on that chrom +gwasByChrom <- list() +addGwas <- function(chrom, study, file, mapping) { + chrom <- chromAdd(chrom) + row <- data.frame(study = study, file = file, + mapping = if (is.na(mapping) || is.null(mapping)) "" else mapping, + stringsAsFactors = FALSE) + gwasByChrom[[chrom]] <<- rbind(gwasByChrom[[chrom]], row) +} +for (i in seq_len(nrow(gwasDf))) { + filePath <- adaptFilePath(gwasDf$file_path[[i]], argv$gwas_meta) + mapping <- if (hasMapCol && nzchar(as.character(gwasDf$column_mapping_file[[i]]))) + adaptFilePath(gwasDf$column_mapping_file[[i]], argv$gwas_meta) else NA_character_ + chromVal <- suppressWarnings(as.integer(gwasDf$chrom[[i]])) + chroms <- if (!is.na(chromVal) && chromVal == 0L) 1:22 else gwasDf$chrom[[i]] + for (ch in chroms) addGwas(ch, gwasDf$study_id[[i]], filePath, mapping) +} + +# ---- analysis regions: --regions BED and/or --region-name ------------------ +regions <- data.frame(chr = character(0), start = integer(0), stop = integer(0), + stringsAsFactors = FALSE) +if (nzchar(argv$regions) && argv$regions != "." && file.exists(argv$regions)) { + rg <- readMeta(argv$regions) + names(rg) <- trimws(names(rg)) + checkCols(rg, c("chr", "start", "stop"), "--regions") + regions <- data.frame(chr = chromAdd(trimws(rg$chr)), + start = as.integer(rg$start), stop = as.integer(rg$stop), + stringsAsFactors = FALSE) +} +rn <- splitVec(strsplit(argv$region_name, ",")[[1L]]) +if (length(rn) > 0L) { + # region_name entries "chr_start_stop" REPLACE the file regions (legacy behaviour) + parts <- strsplit(rn, "_") + regions <- data.frame( + chr = chromAdd(vapply(parts, `[`, character(1), 1L)), + start = as.integer(vapply(parts, `[`, character(1), 2L)), + stop = as.integer(vapply(parts, `[`, character(1), 3L)), + stringsAsFactors = FALSE) +} +regions <- unique(regions) +if (nrow(regions) == 0L) + stop("No analysis regions: provide --regions and/or --region-name.") + +# ---- xQTL weight metadata -------------------------------------------------- +if (is.null(argv$xqtl_meta) || !nzchar(argv$xqtl_meta) || !file.exists(argv$xqtl_meta)) + stop("--xqtl-meta is required and must exist: ", argv$xqtl_meta) +xqtlDf <- readMeta(argv$xqtl_meta) +checkCols(xqtlDf, c("region_id", "#chr", "start", "end", "TSS", "original_data"), + "--xqtl-meta") +xqtlChr <- chromAdd(xqtlDf[["#chr"]]) +xqtlTss <- suppressWarnings(as.integer(xqtlDf$TSS)) + +# ---- per-region: overlapping genes/weights + covering GWAS ----------------- +rows <- list() +skipped <- 0L +for (i in seq_len(nrow(regions))) { + chrom <- regions$chr[[i]]; start <- regions$start[[i]]; stop <- regions$stop[[i]] + hit <- which(xqtlChr == chrom & !is.na(xqtlTss) & + xqtlTss >= start & xqtlTss <= stop) + genes <- character(0); weightFiles <- character(0) + for (j in hit) { + files <- trimws(strsplit(xqtlDf$original_data[[j]], ",")[[1L]]) + files <- files[nzchar(files)] + files <- vapply(files, adaptFilePath, character(1), referenceFile = argv$xqtl_meta, + USE.NAMES = FALSE) + weightFiles <- c(weightFiles, files) + genes <- c(genes, rep(as.character(xqtlDf$region_id[[j]]), length(files))) + } + if (length(weightFiles) == 0L) { skipped <- skipped + 1L; next } + + # GWAS studies covering this chromosome (inline vectors apply to every region) + g <- gwasByChrom[[chrom]] + studies <- character(0); gfiles <- character(0); gmaps <- character(0) + if (length(gwasName) > 0L) { + studies <- gwasName + gfiles <- vapply(gwasData, adaptFilePath, character(1), + referenceFile = argv$gwas_meta, USE.NAMES = FALSE) + gmaps <- if (length(colMap) > 0L) + vapply(colMap, adaptFilePath, character(1), + referenceFile = argv$gwas_meta, USE.NAMES = FALSE) else rep("", length(gwasName)) + } + if (!is.null(g)) { + studies <- c(studies, g$study); gfiles <- c(gfiles, g$file); gmaps <- c(gmaps, g$mapping) + } + + rows[[length(rows) + 1L]] <- data.frame( + region_id = sprintf("%s_%d_%d", chrom, start, stop), + chrom = chrom, start = start, stop = stop, + genes = paste(genes, collapse = ","), + weight_files = paste(weightFiles, collapse = ","), + gwas_studies = paste(studies, collapse = ","), + gwas_files = paste(gfiles, collapse = ","), + gwas_mappings = paste(gmaps, collapse = ","), + stringsAsFactors = FALSE) +} +if (skipped > 0L) + message(sprintf("Skipping %d of %d region(s): no overlapping xQTL weights.", + skipped, nrow(regions))) +if (length(rows) == 0L) + stop("No regions with overlapping xQTL weights; nothing to analyse.") +out <- do.call(rbind, rows) + +writeManifest(out, argv$output) +cat(sprintf("Wrote TWAS manifest with %d region(s) to %s\n", nrow(out), argv$output)) diff --git a/code/script/pecotmr_integration/twas_weights.R b/code/script/pecotmr_integration/twas_weights.R index 13718c5ba..aaeb01b41 100644 --- a/code/script/pecotmr_integration/twas_weights.R +++ b/code/script/pecotmr_integration/twas_weights.R @@ -43,8 +43,6 @@ suppressPackageStartupMessages({ library(argparser) library(pecotmr) - library(GenomicRanges) - library(IRanges) library(jsonlite) }) @@ -70,6 +68,12 @@ parser <- add_argument(parser, "--methods", parser <- add_argument(parser, "--fine-mapping-result", help = "Optional pre-fit FineMappingResult RDS", type = "character", default = "") +parser <- add_argument(parser, "--joint-specification", + help = "Comma-separated joint-analysis axis spec (twasWeightsPipeline jointSpecification), e.g. 'context' for cross-context joint weight learning; empty = per-(context, trait)", + type = "character", default = "") +parser <- add_argument(parser, "--twas-weights", + help = "Optional existing TwasWeights RDS to resume from (twasWeightsPipeline twasWeights); already-computed (context, trait, method) weights are reused for checkpointing/resumption", + type = "character", default = "") parser <- add_argument(parser, "--method-args", help = "JSON object {token: {kwarg: value, ...}, ...} for twasWeightsPipeline()", type = "character", default = "") @@ -80,12 +84,6 @@ parser <- add_argument(parser, "--mixture-prior", "Only consulted when 'mrmash' is in --methods and the prior is not ", "already set via --method-args."), type = "character", default = "") -parser <- add_argument(parser, "--min-twas-maf", - help = "Minimum MAF for the variants used to learn TWAS weights (twasWeightsPipeline minTwasMaf), applied on top of the dataset's construct-time mafCutoff", - type = "numeric", default = 0.01) -parser <- add_argument(parser, "--min-twas-xvar", - help = "Minimum per-variant genotype variance for TWAS weight learning (twasWeightsPipeline minTwasXvar)", - type = "numeric", default = 0.01) parser <- add_argument(parser, "--max-cv-variants", help = "Cap on the number of variants used in cross-validation (twasWeightsPipeline maxCvVariants); -1 = no cap", type = "integer", default = 5000L) @@ -126,20 +124,25 @@ parser <- add_argument(parser, "--output", help = "Output RDS path", type = "character") argv <- parse_args(parser) -# Opt-in overrides of a loaded QtlDataset's construct-time filter slots. Filters -# apply lazily at extraction, so mutating the slot re-filters without rebuilding -# the RDS. Mirrors fine_mapping.R. -apply_qd_filter_overrides <- function(qd, argv) { - if (!is.na(argv$maf_cutoff)) qd@mafCutoff <- argv$maf_cutoff - if (!is.na(argv$mac_cutoff)) qd@macCutoff <- argv$mac_cutoff - if (!is.na(argv$xvar_cutoff)) qd@xvarCutoff <- argv$xvar_cutoff - if (!is.na(argv$imiss_cutoff)) qd@imissCutoff <- argv$imiss_cutoff - if (isTRUE(argv$drop_indel)) qd@keepIndel <- FALSE - read_ids <- function(p) if (nzchar(p) && p != "." && file.exists(p)) - unique(trimws(unlist(strsplit(readLines(p), "[[:space:]]+")))) else NULL - ks <- read_ids(argv$keep_samples); if (!is.null(ks)) qd@keepSamples <- ks - kv <- read_ids(argv$keep_variants); if (!is.null(kv)) qd@keepVariants <- kv - qd +# Read a whitespace-delimited ID file into a unique character vector; NULL when +# the path is empty / "." / missing. +read_ids <- function(p) if (nzchar(p) && p != "." && file.exists(p)) + unique(trimws(unlist(strsplit(readLines(p), "[[:space:]]+")))) else NULL + +# Build the per-call genotype-filter overrides as pipeline ARGUMENTS (NULL = +# leave the QtlDataset's construct-time slot untouched). The pipeline applies +# these to a validated copy; the wrapper no longer mutates @slots directly. +# Mirrors fine_mapping.R. +qd_filter_overrides <- function(argv) { + ov <- list( + mafCutoff = if (!is.na(argv$maf_cutoff)) argv$maf_cutoff else NULL, + macCutoff = if (!is.na(argv$mac_cutoff)) argv$mac_cutoff else NULL, + xvarCutoff = if (!is.na(argv$xvar_cutoff)) argv$xvar_cutoff else NULL, + imissCutoff = if (!is.na(argv$imiss_cutoff)) argv$imiss_cutoff else NULL, + keepIndel = if (isTRUE(argv$drop_indel)) FALSE else NULL, + keepSamples = read_ids(argv$keep_samples), + keepVariants = read_ids(argv$keep_variants)) + ov[!vapply(ov, is.null, logical(1))] } # Seed up front for reproducible fits (mirrors the legacy susie_twas set.seed). @@ -203,14 +206,14 @@ mash_prior <- if (nzchar(argv$mixture_prior) && argv$mixture_prior != "." && MashPrior(fullFit = readRDS(argv$mixture_prior)) } else NULL -parse_region <- function(s) { - m <- regmatches(s, regexec("^([^:]+):([0-9]+)-([0-9]+)$", s))[[1L]] - if (length(m) != 4L) - stop("--region must be in chr:start-end format (got: ", s, ")") - GRanges(seqnames = m[[2L]], - ranges = IRanges(start = as.integer(m[[3L]]), - end = as.integer(m[[4L]]))) -} +# Joint-analysis axis (mirrors fine_mapping.R) and an existing TwasWeights to +# resume from (checkpointing): already-computed (context, trait, method) weights +# are reused so a re-run only fills in the missing methods. +joint_spec <- if (nzchar(argv$joint_specification) && argv$joint_specification != ".") + trimws(strsplit(argv$joint_specification, ",", fixed = TRUE)[[1L]]) else NULL +twas_weights_obj <- if (nzchar(argv$twas_weights) && argv$twas_weights != "." && + file.exists(argv$twas_weights)) readRDS(argv$twas_weights) else NULL + has_gene <- nzchar(argv$gene_id) has_region <- nzchar(argv$region) @@ -220,7 +223,6 @@ if (!has_gene && !has_region) stop("Specify either --gene-id (with --cis-window) or --region.") qd <- readRDS(argv$qtl_dataset) -qd <- apply_qd_filter_overrides(qd, argv) fmr_path <- argv$fine_mapping_result fmr <- if (nzchar(fmr_path) && fmr_path != "." && file.exists(fmr_path)) { @@ -229,22 +231,26 @@ fmr <- if (nzchar(fmr_path) && fmr_path != "." && file.exists(fmr_path)) { NULL } -# Shared args for both modes. minTwas* tighten the variant set used to learn -# the weights (on top of the QtlDataset's construct-time cutoffs); the cv* knobs -# control the cross-validated predictive-performance refits. -tw_args <- list(methods = methods_arg, - mashPrior = mash_prior, - cisWindow = argv$cis_window, - contexts = contexts_arg, - minTwasMaf = argv$min_twas_maf, - minTwasXvar = argv$min_twas_xvar, - maxCvVariants = argv$max_cv_variants, - cvFolds = argv$cv_folds, - cvThreads = argv$cv_threads, - fineMappingResult = fmr) +# Shared args for both modes. Genotype-filter overrides ride on the same +# --maf-cutoff/--xvar-cutoff/... args fine-mapping uses (variant QC is a data +# property, applied identically); the cv* knobs control the cross-validated +# predictive-performance refits. +tw_args <- c(list(methods = methods_arg, + mashPrior = mash_prior, + cisWindow = argv$cis_window, + contexts = contexts_arg, + maxCvVariants = argv$max_cv_variants, + cvFolds = argv$cv_folds, + cvThreads = argv$cv_threads, + fineMappingResult = fmr), + qd_filter_overrides(argv)) +# Opt-in joint axis / resume-from-checkpoint, added only when supplied (keeps +# the call compatible with a pecotmr that predates the argument). +if (!is.null(joint_spec)) tw_args$jointSpecification <- joint_spec +if (!is.null(twas_weights_obj)) tw_args$twasWeights <- twas_weights_obj res <- if (has_region) { do.call(twasWeightsPipeline, - c(list(qd), tw_args, list(region = parse_region(argv$region)))) + c(list(qd), tw_args, list(region = argv$region))) } else { do.call(twasWeightsPipeline, c(list(qd), tw_args, list(traitId = argv$gene_id))) diff --git a/pixi.toml b/pixi.toml new file mode 100644 index 000000000..f9f39be6d --- /dev/null +++ b/pixi.toml @@ -0,0 +1,29 @@ +[workspace] +name = "xqtl-protocol" +channels = ["dnachun", "conda-forge", "bioconda"] +platforms = ["linux-64", "osx-arm64"] + +[system-requirements] +libc = { family="glibc", version="2.17" } + +[tasks] +test = "pytest tests" +test_scripts = "pytest tests/scripts" +test_notebooks = "pytest tests/notebooks" + +[dependencies] +"r-argparser" = "*" +"r-covr" = "*" +"r-jsonlite" = "*" +"r-ggnewscale" = "*" +"r-pkgdown" = "*" +"r-testthat" = "*" +"r-tidyverse" = "*" +"r-pecotmr" = "*" +"coreutils" = "*" +"gzip" = "*" +"pytest" = "*" +"pytest-cov" = "*" +"sos" = "*" +"python" = "3.12.*" +"setuptools" = "<81" diff --git a/tests/README.md b/tests/README.md new file mode 100644 index 000000000..6cdfc6824 --- /dev/null +++ b/tests/README.md @@ -0,0 +1,58 @@ +# xqtl-protocol wrapper tests + +`pytest` is the single orchestrator for the pipeline's thin CLI wrapper scripts. +Each test drives a wrapper exactly as the pipeline does — `Rscript